perm filename PUB.SAI[PUB,TES]3 blob
sn#077422 filedate 1973-12-10 generic text, type T, neo UTF8
00100 BEGIN "PUB" COMMENT Begun April 23, 1971, Completed Asymptotically ;
00200
00300
00400 COMMENT FILES TO COMPILE:
00500
00600 PUB.SAI (This one)
00700 FILLER.SAI (The Line Filler)
00800 PARSER.SAI (The Command Scanner/Parser)
00900
01000 REQUIRED FILES:
01100 By all: PUBDFS.SAI PUBINR.SAI
01200 By FILLER and PARSER only:
01300 PUBMAI.SAI PUBPRO.SAI
01400
01500 NEEDED TO RUN PUB:
01600 PUB.DMP (From this compilation)
01700 PUB2.DMP (From compiling PUB2.SAI)
01800 PUBSTD.DFS (Standard Macro File)
01900 SYS:TXTF80.DMP (For microfilm output only)
02000
02100 FORMS FOR THE DEBUG SWITCH (BREAKPOINTS A LINE):
02200 /Z04100/2/ or (Z04100/2/) Manuscript P. 2 Line 04100
02300 /ZPUB33/1/ or (ZPUB33/1/) PUBSTD.DFS P. 1 Line 33
02400
02500 DOCUMENTATION FILES:
02600 PUB.DOC[S,DOC]
02700 PUBMAC.DOC[S,DOC]
02800
02900 DO FILE FOR GENERATING SYSTEM (DO NIT):
03000 LOAD PUB.SAI(5000S),PARSER.SAI(5000S),FILLER.SAI(5000SR)↔SAVE PUB↔DO NIT(2)↔|
03100 LOAD PUB2.SAI(5000SR)↔SAVE PUB2↔
03200
03300 If the user is logged in as xx2,TES then PUB expects
03400 PUB2.DMP and PUBSTD.DFS to be in the same directory.
03500 Otherwise, it expects them to be in 1,3
03600 ;
03700
03800 DEFINE TERNAL = "INTERNAL", PRELOAD = "PRELOAD_WITH" ;
03900 REQUIRE "PUBDFS.SAI" SOURCE_FILE ;
04000 comment, The DEFINEs, constant-bound arrays, and global variables ;
04100
04150 TES AND DCS 11/29/73: ;
04200 REQUIRE IFC VERSION=PARCVER THENC 30000 ELSEC 4000 ENDC STRING_SPACE ;
04300 REQUIRE 400 SYSTEM_PDL ; REQUIRE 200 STRING_PDL ;
00100 EXTERNAL INTEGER SIMPLE PROCEDURE XLENGTH(STRING S);
00200 EXTERNAL PROCEDURE READFONT(INTEGER WHICH; STRING FILENAME);
00300
00400 COMMENT The following INTERNAL SIMPLE PROCEDUREs are EXTERNAL in PUBMAI.SAI ;
00500
00600 INTERNAL STRING SIMPLE PROCEDURE SPS(INTEGER N) ; IF N≤10 THEN RETURN(SPSARR[N MAX 0]) ELSE
00700 BEGIN
00800 STRING S ; INTEGER I ;
00900 S ← " " ;
01000 FOR I ← 20 STEP 10 UNTIL N DO S ← S & " " ;
01100 RETURN(S & SPSARR[N-I+10]) ;
01200 END ;
01300
01400 COMMENT DYNAMIC ARRAY MANIPULATION PACKAGE (ARRSER.SAI[1,DCS]) ;
01500
01600 EXTERNAL INTEGER GOGTAB ;
01700
01800 DSCR PTR←WHATIS(ARRAY)
01900 PAR ARRAY OF ANY ARITHMETIC OR SET BREED
02000 RES PTR←DSCRPTR, SAIL CAN THEN TREAT IT AS AN INTEGER
02100 ;
02200
02300 INTERNAL INTEGER SIMPLE PROCEDURE WHATIS(INTEGER ARRAY A);
02400 START_CODE "WHATIS"
02500 MOVE 1,A;
02600 END "WHATIS";
02700
02800
02900
03000 DSCR PTR←SWHATIS(ARRAY)
03100 PAR STRING ARRAY
03200 RES PTR←DSCRPTR, SAIL CAN THEN TREAT IT AS AN INTEGER
03300 ;
03400
03500 INTERNAL INTEGER SIMPLE PROCEDURE SWHATIS(STRING ARRAY A);
03600 START_CODE "SWHATIS"
03700 MOVE 1,A;
03800 END "SWHATIS";
03900
04000
04100 DSCR GOAWAY(PTR)
04200 PAR PTR IS ARRAY DESCRIPTOR
04300 DES ARRAY IS RLEASD
04400 ;
04500
04600 INTERNAL SIMPLE PROCEDURE GOAWAY(INTEGER I) ;
04700 BEGIN COMMENT Be SURE Left Half is -1 for String Arrays! ;
04800 START_CODE MOVE '15, GOGTAB END ;
04900 IF LH(I) THEN
05000 START_CODE "SARID"
05100 HRRZ 1, I ; MOVE 1, 0(1) ; COMMENT [PREV,,NEXT] ;
05200 HLRZ 2, 1 ; HRRM 1, 0(2) ; COMMENT PREV ← [...,,NEXT] ;
05300 HRRZ 2, 1 ; SKIPE 2 ; HLLM 1, 0(2) ; COMMENT NEXT ← [PREV,,...] ;
05400 END "SARID" ;
05500 ARYEL(I) ;
05600 END "GOAWAY" ;
00100 INTERNAL INTEGER SIMPLE PROCEDURE BIGGER(INTEGER PTR,HM);
00200 BEGIN "BIGGER"
00300 INTEGER PT;
00400 START_CODE "BIG1"
00500 MOVE '15, GOGTAB ; COMMENT BECAUSE OF LRCOP BUG ;
00600 MOVE TEMPO,HM;
00700 MOVE LPSA,PTR;
00800 ADDM TEMPO,-3(LPSA);
00900 ADDM TEMPO,-1(LPSA);
01000 MOVNS TEMPO;
01100 ADDM TEMPO,-6(LPSA);
01200 END "BIG1";
01300 PT←LRCOP(PTR); "DO THE COPY AND INCREASE"
01400 START_CODE "BIG2"
01500 MOVE TEMPO,HM;
01600 MOVE LPSA,PTR;
01700 ADDM TEMPO,-6(LPSA);
01800 END "BIG2";
01900 GOAWAY(PTR); "DELETE THE OLD COPY"
02000 RETURN(PT); "HERE IS THE NEW COPY";
02100 END "BIGGER";
02200
02300
02400 DSCR PTR1←SBIGGER(PTR,HOWMUCH)
02500 PAR PTR IS ARRAY (1-D STRING) DESCRIPTOR
02600 HOWMUCH NUMBER OF ELEMENTS INCREASE DESIRED
02700 RES PTR1 IS DESCRIPTOR OF BIGGER ARRAY
02800 THE OLD DATA IS COPIED, THE OLD ARRAY HAS DISAPPEARED
02900 ;
03000
03100 INTERNAL INTEGER SIMPLE PROCEDURE SBIGGER(INTEGER PTR,HM);
03200 BEGIN "SBIGGER"
03300 INTEGER PT;
03400 START_CODE "SBIG1"
03500 MOVE '15, GOGTAB ;
03600 MOVE TEMPO,HM;
03700 MOVE LPSA,PTR;
03800 ADDM TEMPO,-4(LPSA);
03900 LSH TEMPO,1;
04000 ADDM TEMPO,-2(LPSA);
04100 MOVNS TEMPO;
04200 ADDM TEMPO,-7(LPSA);
04300 END "SBIG1";
04400 PT←LRCOP(PTR); "DO THE COPY AND INCREASE"
04500 START_CODE "SBIG2"
04600 MOVE TEMPO,HM;
04700 MOVE LPSA,PTR;
04800 LSH TEMPO,1;
04900 ADDM TEMPO,-7(LPSA);
05000 END "SBIG2";
05100 GOAWAY(PTR); "DELETE THE OLD COPY"
05200 RETURN(PT); "HERE IS THE NEW COPY";
05300 END "SBIGGER";
00100 COMMENT Declares
00200 IDA ← [S]CREATE(LOWBND, HIGHBND) to create a (string or) integer array
00300 MAKEBE(IDA,ALIAS) to give its descriptor to array ALIAS
00400 IDA ← [S]WHATIS(ALIAS) to take it back
00500 GOAWAY(IDA) to destroctulate it
00600 IDA ← [S]BIGGER(IDA,XTRA) to add XTRA words to its length ;
00700
00800
00900 INTEGER SIMPLE PROCEDURE SCREATE(INTEGER LB1, UB1) ;
01000 BEGIN "SCREATE"
01100 INTEGER IDA ;
01200 START_CODE MOVE '15, GOGTAB END ;
01300 IDA ← LRMAK(LB1, UB1, -1 LSH 18 + 1) ;
01400 RETURN(IDA) ;
01500 END "SCREATE" ;
01600
01700 INTERNAL INTEGER SIMPLE PROCEDURE CREATE2(INTEGER LB1, UB1, LB2, UB2) ;
01800 BEGIN "CREATE2"
01900 EXTERNAL INTEGER SIMPLE PROCEDURE LRMAK(INTEGER LB1, UB1, LB2, UB2, D) ;
02000 START_CODE MOVE '15, GOGTAB END ; COMMENT LRCOP BUG ;
02100 RETURN(LRMAK(LB1, UB1, LB2, UB2, 2)) ;
02200 END "CREATE2" ;
02300
02400 INTERNAL STRING SIMPLE PROCEDURE ERRLINE ;
02500 RETURN(IF EQU(MAINFILE, THISFILE) THEN SRCLINE
02600 ELSE THISFILE&SP&SRCLINE) ;
02700
02800 INTERNAL STRING SIMPLE PROCEDURE WARN(STRING SHORT_VERSION,LONG_VERSION) ;
02900 BEGIN "WARN"
03000 IF SWDBACK ≤ 0 THEN OUTSTR(CRLF) ; COMMENT 2/27/73 TES ;
03100 USERERR(0, 1, LONG_VERSION&CRLF&" just above (or on) "&ERRLINE&"/"&SRCPAGE&"["&MACLINE&"]") ;
03200 IF DEBUG ∧ MESGS<MESSMAX ∧ LENGTH(SHORT_VERSION) THEN
03300 MESSAGE[MESGS←MESGS+1] ← IF SHORT_VERSION = "=" THEN LONG_VERSION ELSE SHORT_VERSION ;
03400 SWDBACK ← 1 ; COMMENT 2/27/73 TES ;
03500 RETURN(NULL) ;
03600 END "WARN" ;
00100 BOOLEAN GENEXT ;
00200
00300 SIMPLE PROCEDURE ANYSTART(STRING COMDLINE) ; NB Both RPGSTART and SSTART call this one;
00400 BEGIN "ANYSTART"
00500 STRING WD, OPTIONS, N, M ; INTEGER FIL, EXT, PPN ;
00600 SETBREAK(1, "←/()", CR&LF&TB&FF&SP, "INS") ;
00700 SETBREAK(2, DIGS, SP, "XNS") ;
00800 OUTFILE ← SCAN(COMDLINE, 1, BRC) ;
00900 IF BRC ≠ "←" THEN INFILE ← OUTFILE ;
01000 FIL ← CVFIL(OUTFILE, EXT, PPN) ; N ← IF PPN THEN CVXSTR(PPN) ELSE NULL ;
01100 M ← CVXSTR(FIL) ;
01200 GENEXT ← EXT=0 OR BRC≠"←";
01300 IF GENEXT THEN OUTFILE ← CVXSTR(FIL);
01400 TMPFILE ← CVXSTR(FIL) & ".RPG" ;
01500 WHILE BRC ∧ BRC≠"(" ∧ BRC≠"/" DO
01600 BEGIN "INPUT FILE NAME"
01700 WD ← SCAN(COMDLINE, 1, BRC) ;
01800 IF FULSTR(WD) THEN
01900 BEGIN
02000 IF FULSTR(INFILE) THEN
02100 WARN(NULL,"ONLY 1 INPUT FILE ALLOWED -- "
02200 & INFILE & " SKIPPED") ;
02300 INFILE ← WD ;
02400 END ;
02500 END "INPUT FILE NAME" ;
02600 WHILE BRC="/" DO OPTIONS ← OPTIONS & SCAN(COMDLINE,1,BRC) ;
02700 IF BRC = "(" THEN DO OPTIONS ← OPTIONS & SCAN(COMDLINE,1,BRC) & (IF BRC="/" THEN BRC ELSE NULL)
02800 UNTIL BRC = 0 OR BRC = ")" ;
02900 IF FULSTR(OPTIONS) THEN
03000 DO BEGIN
03100 N ← SCAN(OPTIONS, 2, BRC) ;
03200 IF BRC = "d" ∨ BRC = "D" THEN DEBUG ← -1
03300 ELSE IF BRC = "s" ∨ BRC = "S" THEN PREFMODE ← IF NULSTR(N) THEN 1 ELSE CVD(N)
03400 ELSE IF BRC = "m" ∨ BRC = "M" THEN DEVICE ← -MIC
03500 ELSE IF BRC = "t" ∨ BRC = "T" THEN DEVICE ← -TTY
03600 ELSE IF BRC = "l" ∨ BRC = "L" THEN DEVICE ← -LPT
03700 ELSE IF BRC = "x" ∨ BRC = "X" THEN DEVICE ← -XGP RKJ;
03800 ELSE IF BRC = "z" ∨ BRC = "Z" THEN
03900 LSTOP ← SCAN(OPTIONS,1,BRC) & "/" & SCAN(OPTIONS,1,BRC)
04000 ELSE IF BRC="n" ∨ BRC="N" ∨ BRC="y" ∨ BRC="Y" ∨ BRC="a" ∨ BRC="A" THEN DELINT ← BRC
04100 ELSE IF BRC = "c" ∨ BRC = "C" THEN CONTENTS ← -1
04200 ELSE IF BRC = "b" ∨ BRC = "B" THEN SYMNO ← BIG_SIZE - 1
04300 ELSE IF BRC = "h" ∨ BRC = "H" THEN SYMNO ← HUGE_SIZE - 1
04400 ELSE IF BRC = "t" ∨ BRC = "T" THEN M ← N
04500 ELSE IF BRC = "P" AND OPTIONS = "U" THEN
04600 OPTIONS ← OPTIONS[3 TO ∞] COMMENT /PUB ;
04700 ELSE IF BRC = "p" ∨ BRC = "P" OR (BRC = 0 AND FULSTR(M)) THEN
04800 BEGIN
04900 IF BRC = 0 THEN N ← "99999" ;
05000 IF INPGS ≥ 10 THEN WARN(NULL,"ONLY 10 mTnP OPTIONS ALLOWED")
05100 ELSE INPG[INPGS←INPGS+1] ← LHRH("CVD(IF NULSTR(M) THEN N ELSE M)", "CVD(N)") ;
05200 M ← NULL ;
05300 END
05400 ELSE IF BRC ≠ 0 THEN WARN(NULL,"NEVER HEARD OF A " & BRC & " OPTION") ;
05500 END
05600 UNTIL BRC = 0 ;
05700 XCRIBL ← IF DEVICE = -XGP THEN TRUE ELSE FALSE; RKJ;
05800 BREAKSET(1, NULL, "O") ; BREAKSET(2, NULL, "O") ;
05900 END "ANYSTART" ;
00100 SIMPLE PROCEDURE RPGSTART ;
00200 BEGIN "RPGSTART"
00300 BOOLEAN QQSVCM ; STRING CMD ;
00400 EOF ← 0 ; OPEN(0, "DSK", 0, 1, 0, 50, BRC, EOF) ;
00500 LOOKUP(0, "QQSVCM.RPG", FLAG) ;
00600 IF FLAG THEN
00700 BEGIN
00800 LOOKUP(0, "QQPUB.RPG", FLAG) ;
00900 IF FLAG THEN WARN(NULL,"NO RPG FILES") ELSE QQSVCM←FALSE ;
01000 END
01100 ELSE QQSVCM ← TRUE ;
01200 SETBREAK(1, LF, CR, "INS") ;
01300 CMD ← INPUT(0,1) ;
01400 IF QQSVCM THEN
01500 BEGIN
01600 COMMENT THE QQSVCM FILE HAS A SUPERFLUOUS COMPILE AND MAYBE /PUB ;
01700 WHILE CMD=SP OR CMD=TB DO LOPP(CMD) ;
01800 WHILE CMD NEQ SP AND CMD NEQ TB DO LOPP(CMD) ;
01900 WHILE CMD=SP OR CMD=TB DO LOPP(CMD) ;
02000 IF EQU(CMD[1 TO 4], "/PUB") THEN CMD ← CMD[5 TO ∞] ;
02100 END ;
02200 ANYSTART(CMD) ; RELEASE(0) ;
02300 END "RPGSTART" ;
02400
02500 SIMPLE PROCEDURE SSTART ;
02600 BEGIN "SSTART"
02700 STRING S ;
02800 DO BEGIN OUTCHR("*"); S←INCHWL; END UNTIL FULSTR(S);
02900 ANYSTART(S);
03000 END "SSTART";
03100
03200
03300
03400
03500
03600 COMMENT E X E C U T I O N B E G I N S . . . . ;
03700
03800 ONE ← 1 ; NB Variable upper bound for ALIAS arrays;
03900 SYMNO ← REGULAR_SIZE - 1 ; NB Assume for now that symbol table is regular size;
04000 INPGS ← 0 ; INFILE ← NULL ; PREFMODE ← 1 ; DEVICE ← LPT ; DELINT ← "Y" ;
04100 IF RPGSW THEN RPGSTART ELSE SSTART; NB Read file names and options;
04200 INITSIZES ;
00100 BEGIN "VARIABLE BOUND ARRAY BLOCK"
00200
00300 REQUIRE "PUBINR.SAI" SOURCE_FILE ;
00400 comment, Arrays whose sizes depend on CUSP options. Also SYMSER.SAI variables ;
00500
00600 COMMENT
00700 SYMSER.SAI package -- LOOKUP and ENTER procedures for hashed
00800 symbol tables -- STRINGS -- uses quadratic search.
00900
01000 REQUIRED --
01100 1. DEFINE SYMNO="1 less than some relatively prime number big
01200 enough to hold all entries"
01300 2. REQUIRE "SYMSER.SAI[1,DCS]" SOURCE_FILE in outer block
01400 declaration code
01500
01600 WHAT YOU GET ---
01700 1. An array, SYM, to hold the (STRING) symbols you enter.
01800 2. Another array, NUMBER, to hold the (INTEGER) values
01900 associated with the array
02000 3. An index, SYMBOL, set to the correct SYM/NUMBER element
02100 after a lookup
02200
02300 4. An integer, ERRFLAG, set to TRUE if errors occur in ENTERSYM
02400
02500
02600 5. A Procedure, FLAG←LOOKSYM("A") which returns:
02700 TRUE if the symbol is already present in the SYM table.
02800 FALSE if the symbol is not found --
02900 SYMBOL will have the value -1 (table full), or
03000 will be an index of a free entry (see ENTERSYM)
03100
03200 6. A Procedure, ENTERSYM("SYM",VAL) which does:
03300 Checks for symbol full or duplicate symbol -- if detected,
03400 types message and sets ERRFLAG TRUE
03500 Puts SYM and VAL in SYM/NUMBER arrays at SYMBOL index
03600
03700 7. A Procedure, SYMSET, which initializes the table.
03800 SYM[0] is initted to a blank string -- you can use
03900 this information if you wish.
04000
04100 ;
00100 COMMENT Most of the procedures in this block are INTERNAL. They are EXTERNAL in PUBPRO.SAI ;
00200
00300 INTERNAL SIMPLE PROCEDURE SETSYM;
00400 BEGIN "SETSYM"
00500 INTEGER I;
00600 FOR I← 1 STEP 1 UNTIL SYMNO DO SYM[I]←NULL;
00700 SYM[0]←" ";
00800 ERRFLAG←FALSE
00900 END "SETSYM";
01000
01100 INTERNAL INTEGER SIMPLE PROCEDURE LOOKSYM(STRING A);
01200 BEGIN "LOOKSYM"
01300 INTEGER H,Q,R;
01400 DEFINE SCON="10";
01500 H←CVASC(A) +LENGTH(A) LSH 6;
01600 R←SYMBOL←(H←ABS(H⊗(H LSH 2))) MOD (SYMNO+1);
01700
01800 IF EQU(SYM[SYMBOL],A) THEN RETURN(-1);
01900 IF NULSTR(SYM[SYMBOL]) THEN RETURN(0);
02000
02100 Q←H%(SYMNO+1) MOD (SYMNO+1);
02200 IF (H←Q+SCON)≥SYMNO THEN H←H-SYMNO;
02300
02400 WHILE (IF (SYMBOL←SYMBOL+H)>SYMNO
02500 THEN SYMBOL←SYMBOL-(SYMNO+1) ELSE SYMBOL) ≠R DO
02600 BEGIN "LK1"
02700 IF EQU(SYM[SYMBOL],A) THEN RETURN(-1);
02800 IF NULSTR(SYM[SYMBOL]) THEN RETURN(0);
02900 IF (H←H+Q)>SYMNO THEN H←H-(SYMNO+1);
03000 END "LK1";
03100 SYMBOL←-1; RETURN(0);
03200 END "LOOKSYM";
03300
03400 INTERNAL SIMPLE PROCEDURE ENTERSYM(STRING WORD; INTEGER VAL);
03500 BEGIN "ENTERSYM"
03600 IF LENGTH(SYM[SYMBOL])∨SYMBOL<0 THEN
03700 BEGIN
03800 ERRFLAG←1;
03900 IF SYMBOL≥0 THEN PRINT "DUPLICATE SYMBOL "&WORD MSG
04000 ELSE PRINT "SYMBOL TABLE FULL" MSG ;
04100 END
04200 ELSE
04300 BEGIN
04400 SYM[SYMBOL]←WORD;
04500 NUMBER[SYMBOL]←VAL;
04600 END;
04700 END "ENTERSYM";
00100 COMMENT P A S S O N E P R O C E D U R E S - - - - - - - - - - - - - - - ;
00200
00300 EXTERNAL SIMPLE PROCEDURE SELECTFONT(INTEGER WHICH);
00400 EXTERNAL RECURSIVE PROCEDURE DBREAK ;
00500 EXTERNAL RECURSIVE BOOLEAN PROCEDURE TEXTLINE ; comment, INTERNAL in FILLER.SAI ;
00600 EXTERNAL RECURSIVE BOOLEAN PROCEDURE CHUNK(BOOLEAN VALID) ;
00700 EXTERNAL RECURSIVE STRING PROCEDURE PASS ; comment, INTERNAL in PARSER.SAI ;
00800 EXTERNAL STRING SIMPLE PROCEDURE EVALV(STRING THISWD ; INTEGER IX, TYP) ;
00900 EXTERNAL RECURSIVE STRING PROCEDURE E(STRING DEFAULT, STOPWORD) ;
01000 EXTERNAL SIMPLE PROCEDURE RDENTITY ;
01040 EXTERNAL SIMPLE STRING PROCEDURE PICKFONT(INTEGER F) ; TES 11/29/73;
01080 EXTERNAL SIMPLE INTEGER PROCEDURE RFONT(INTEGER F) ; TES 11/29/73;
01100
01200 FORWARD INTERNAL RECURSIVE PROCEDURE CLOSEAREA(INTEGER ITSIX; BOOLEAN DISDECLAREIT) ;
01300 FORWARD INTERNAL RECURSIVE PROCEDURE CLOSEUNIT(INTEGER ITSIX; BOOLEAN DISDECLAREIT) ;
01400
01500 INTERNAL STRING SIMPLE PROCEDURE SOMEINPUT ;
01600 RETURN(SP&THISWD&SP&
01700 (IF THATISFULL THEN LIT_ENTITY&LIT_TRAIL ELSE NULL)&INPUTSTR[1 TO 80]);
01800
01900 INTERNAL SIMPLE PROCEDURE IMPOSSIBLE(STRING WHERE); WARN("=","IMPOSSIBLE CASE INDEX IN "&WHERE&" AT "&SOMEINPUT);
02000
02100 INTERNAL STRING SIMPLE PROCEDURE CAPITALIZE(STRING MIXEDCASE) ;
02200 BEGIN "CAPITALIZE"
02300 INTEGER C ; STRING S ; S ← 0&MIXEDCASE ; LOPP(S) ; C ← LENGTH(MIXEDCASE) ; IF ¬C THEN RETURN(NULL);
02400 START_CODE "CAPIT" LABEL NEXC ; MOVE 1, S ; MOVE 2, C ;
02500 NEXC: ILDB 3, 1 ; LDB 3, UPCAS3 ; DPB 3, 1 ; SOJG 2, NEXC ;
02600 END "CAPIT" ; RETURN(S) ;
02700 END "CAPITALIZE" ;
02800
02900 SIMPLE PROCEDURE ZEROWORDS(INTEGER WDS; REFERENCE INTEGER LOCN) ;
03000 BEGIN "ZEROWORDS"
03100 START_CODE "ZOT"
03200 LABEL DUN ;
03300 SKIPG 1, WDS ;
03400 JRST DUN ; COMMENT NO WDS TO ZERO -- QUIT ;
03500 HRRZ 2, -1('17) ; COMMENT LOCN ;
03600 SETZM 0(2) ;
03700 CAIN 1, 1 ;
03800 JRST DUN ; COMMENT ONLY 1 -- DON'T BLT ! ;
03900 ADDI 1, -1(2) ;
04000 HRL 2, 2 ;
04100 ADDI 2, 1 ;
04200 BLT 2, (1) ;
04300 DUN:
04400 END ;
04500 END "ZEROWORDS" ;
04600
04700 INTERNAL SIMPLE PROCEDURE ZEROSTRINGS(INTEGER STRS; REFERENCE STRING LOCN) ;
04800 BEGIN
04900 START_CODE "ZOS"
05000 LABEL DUN ;
05100 SKIPG 1, STRS ;
05200 JRST DUN ; COMMENT NO STRS TO ZERO -- QUIT ;
05300 ADD 1, 1 ; COMMENT TWO WORDS PER STRING ;
05400 HRRZ 2, -1('17) ; COMMENT LOCN ;
05500 SUBI 2, 1 ; COMMENT POINT TO COUNT WORD FIRST ;
05600 SETZM 0(2) ;
05700 ADDI 1, -1(2) ;
05800 HRL 2, 2 ;
05900 ADDI 2, 1 ;
06000 BLT 2, (1) ;
06100 DUN:
06200 END ;
06300 END "ZEROSTRINGS" ;
06400
00100 INTERNAL SIMPLE PROCEDURE GROW(REFERENCE INTEGER ARRAY ARR; REFERENCE INTEGER IDA,WDS;
00200 INTEGER EXTRA; STRING WHY) ;
00300 BEGIN "GROW"
00400 IDA ← RH("BIGGER(WHATIS(ARR),EXTRA)"); WDS ← WDS + EXTRA ;
00500 IF WDS ≥ TWO(14) THEN WARN(NULL,"Table grown to 2↑14 entries. Utterly unmanageable. Goodbye!") ;
00600 END "GROW" ;
00700
00800 INTERNAL SIMPLE PROCEDURE SGROW(REFERENCE STRING ARRAY ARR; REFERENCE INTEGER IDA,WDS;
00900 INTEGER EXTRA; STRING WHY) ;
01000 BEGIN "SGROW"
01100 IDA ← RH("SBIGGER(SWHATIS(ARR),EXTRA)"); WDS ← WDS + EXTRA ;
01200 IF WDS ≥ TWO(14) THEN WARN(NULL,"Table grown to 2↑14 entries. Utterly unmanageable. Goodbye!") ;
01300 END "SGROW" ;
01400
01500 INTERNAL SIMPLE PROCEDURE GROWNESTS ;
01600 BEGIN "GROWNESTS"
01700 GROW(INEST, INESTIDA, SIZE, 200, NULL) ; MAKEBE(INESTIDA, INEST) ;
01800 DUMMY ← 0 ; COMMENT OTHERWISE SPURIOUS MESSAGE FROM SGROW 2/28/73 TES ;
01900 SGROW(SNEST, SNESTIDA, DUMMY, 200, NULL) ; SMAKEBE(SNESTIDA, SNEST) ;
02000 ZEROSTRINGS(200, SNEST[SIZE-199]) ;
02100 END "GROWNESTS" ;
02200
02300 INTERNAL SIMPLE PROCEDURE GROWOWLS(INTEGER EXTRA) ;
02400 BEGIN "GROWOWLS"
02500 GROW(MOLES, MOLESIDA, OLXX, EXTRA, NULL) ; MAKEBE(MOLESIDA, MOLES) ;
02600 GROW(SHORT, SHORTIDA, DUMMY←0, EXTRA, NULL) ; MAKEBE(SHORTIDA, SHORT) ;
02700 DUMMY ← 0 ; COMMENT OTHERWISE SPURIOUS MESSAGE FROM GROW 2/28/73 TES ;
02800 GROW(OWLS, OWLSIDA, DUMMY, EXTRA, NULL) ;
02900 MAKEBE(OWLSIDA, OWLS) ; OWLSF ← OWLSIDA ; MOLESF ← MOLESIDA ; SHORTF ← SHORTIDA ;
03000 END "GROWOWLS" ;
03100
03200 INTERNAL INTEGER SIMPLE PROCEDURE PUSHI(INTEGER WDS, TYP) ;
03300 BEGIN "PUSHI"
03400 INTEGER QI ;
03500 IF (IHED ← IHED + WDS+1) > ISIZE THEN
03600 BEGIN
03700 GROW(ISTK, ISTKIDA, ISIZE, 1000, NULL) ;
03800 MAKEBE(ISTKIDA,ISTK)
03900 END ;
04000 ISTK[IHED] ← TYP ROT -9 LOR (IHED-WDS-1) ;
04100 ZEROWORDS(WDS, ISTK[IHED-WDS]) ; RETURN(IHED) ;
04200 END "PUSHI" ;
04300
04400 INTERNAL INTEGER SIMPLE PROCEDURE PUSHS(INTEGER WDS; STRING FIRST) ;
04500 BEGIN"PUSHS"
04600 INTEGER QI ;
04700 IF (SHED ← SHED + WDS) > SSIZE THEN
04800 BEGIN
04900 SGROW(SSTK, SSTKIDA, SSIZE, 200, NULL) ;
05000 SMAKEBE(SSTKIDA,SSTK) ; ZEROSTRINGS(200, SSTK[SSIZE-199]) ;
05100 END ;
05200 SSTK[SHED] ← FIRST ;
05300 FOR QI←WDS-1 DOWN 1 DO SSTK[SHED-QI]←NULL ; RETURN(SHED) ;
05400 END "PUSHS" ;
05500
05600 INTERNAL INTEGER SIMPLE PROCEDURE PUTI(INTEGER WDS, FIRST) ;
05700 BEGIN"PUTI"
05800 INTEGER QI ;
05900 IF (IHIGH ← IHIGH + WDS) > ITSIZE THEN
06000 BEGIN
06100 GROW(ITBL, ITBLIDA, ITSIZE, 300, NULL) ;
06200 MAKEBE(ITBLIDA,ITBL) ;
06300 END ;
06400 ITBL[IHIGH] ← FIRST ;
06500 ZEROWORDS(WDS-1, ITBL[IHIGH-WDS+1]) ; RETURN(IHIGH) ;
06600 END "PUTI" ;
06700
06800 INTERNAL INTEGER SIMPLE PROCEDURE PUTS(STRING VAL) ;
06900 BEGIN"PUTS"
07000 INTEGER QI ;
07100 IF (SHIGH ← SHIGH + 1) > STSIZE THEN
07200 BEGIN
07300 SGROW(STBL, STBLIDA, STSIZE, 200, NULL) ;
07400 SMAKEBE(STBLIDA,STBL) ; ZEROSTRINGS(200, STBL[STSIZE-199]) ;
07500 END ;
07600 STBL[SHIGH] ← VAL ;
07700 RETURN(SHIGH) ;
07800 END "PUTS" ;
07900
08000 IFC TENEX THENC TES 10/25/73 ;
08100 INTERNAL BOOLEAN SIMPLE PROCEDURE XLOOKUP(INTEGER CHAN; STRING NAME, EXT; INTEGER JUNK; STRING PPN) ;
08200 BEGIN COMMENT RETURNS TRUE IF SUCCESSFUL ;
08300 BOOLEAN FLAG ;
08400 LOOKUP(CHAN, PPN & NAME & EXT, FLAG) ;
08500 RETURN(NOT FLAG) ;
08600 END ;
08700
08800 STRING PROCEDURE SCANTO(STRING BRKS; REFERENCE STRING SCANNEE; BOOLEAN INCLUDE) ;
08900 BEGIN
09000 INTEGER DUMMY ;
09100 SETBREAK(LOCAL_TABLE, BRKS, NULL, IF INCLUDE THEN "IA" ELSE "IR") ;
09200 RETURN(SCAN(SCANNEE, LOCAL_TABLE, DUMMY)) ;
09300 END ;
09400
09500 STRING SIMPLE PROCEDURE CVFIL(STRING FILENAME; REFERENCE STRING EXT, PPN) ;
09600 BEGIN
09700 STRING NAME ;
09800 PPN ← IF FILENAME[1 FOR 1] = "<" THEN SCANTO(">", FILENAME, TRUE) ELSE NULL ;
09900 NAME ← SCANTO(".;", FILENAME, FALSE) ;
10000 EXT ← IF FILENAME[1 FOR 1] = "." THEN SCANTO(";", FILENAME, FALSE) ELSE NULL ;
10100 RETURN(NAME) ;
10200 END ;
10300 ELSEC
10400 INTERNAL BOOLEAN SIMPLE PROCEDURE XLOOKUP(INTEGER CHAN, NAME, EXT, JUNK, PPN) ;
10500 START_CODE "XLOOKUP"
10600 MOVE 2,CHAN;
10700 LSH 2,23;
10800 IOR 2,['076017777774]; COMMENT LOOKUP 0,-4(17) ;
10900 SETO 1,0; COMMENT TRUE ;
11000 XCT 0,2;
11100 SETZ 1,0; COMMENT FALSE ;
11200 END "XLOOKUP";
11300 ENDC
00100 INTERNAL SIMPLE PROCEDURE SWICH(STRING NEWINPUTSTR; INTEGER NEWINPUTCHAN, ARGS) ;
00200 BEGIN "SWICH" comment switch to new input stream ;
00300 IF ARGS THEN
00400 BEGIN "SUBSTITUTE"
00500 INTEGER BRC ; STRING NEWER ; NEWER ← NULL ; LAST ← LAST - ARGS ;
00600 DO BEGIN "VTABS"
00700 NEWER ← NEWER & SCAN(NEWINPUTSTR, TO_VT_SKIP, BRC) ;
00800 IF BRC THEN NEWER ← NEWER & SNEST[LAST + LOP(NEWINPUTSTR)] ;
00900 END "VTABS"
01000 UNTIL BRC = 0 ;
01100 NEWINPUTSTR ← NEWER ;
01200 END "SUBSTITUTE" ;
01300 IF (LAST ← LAST+2) > SIZE THEN GROWNESTS ;
01400 STRSCAN(LAST) ← IF THATISFULL THEN LIT_ENTITY & LIT_TRAIL & INPUTSTR ELSE INPUTSTR ;
01500 CHANSCAN(LAST) ← INPUTCHAN + (IF TECOFILE THEN 100 ELSE 0) ;
01600 LINESCAN(LAST) ← IF INPUTCHAN < 0 THEN MACLINE ELSE THISFILE & VT & SRCLINE ;
01700 PAGESCAN(LAST) ← LHRH(PAGEMARKS, PAGEWAS) ;
01800 EMPTYTHIS ; EMPTYTHAT ;
01900 INPUTSTR ← NEWINPUTSTR ; INPUTCHAN ← NEWINPUTCHAN ; TECOFILE ← 0 ;
02000 END "SWICH" ;
02100
02200 INTERNAL STRING SIMPLE PROCEDURE SWICHBACK ;
02300 BEGIN "SWICHBACK"
02400 EOF ← 0 ; IF INPUTCHAN≥0 THEN
02500 BEGIN
02600 IF PUBSTD THEN PUBSTD ← FALSE ELSE SWDBACK ← TRUE ;
02700 CHANLS[INPUTCHAN]←0; RELEASE(INPUTCHAN) ;
02800 END ;
02900 PAGEMARKS ← LH("DUMMY ← ABS(PAGESCAN(LAST))") ; PAGEWAS ← RH(DUMMY) ;
03000 SRCPAGE ← CVS(PAGEMARKS) ;
03100 IF (INPUTCHAN ← CHANSCAN(LAST))< 0 THEN MACLINE←LINESCAN(LAST)
03200 ELSE BEGIN SRCLINE←LINESCAN(LAST);
03300 THISFILE←SCAN(SRCLINE,TO_VT_SKIP,DUMMY) END ;
03400 IF TECOFILE ← INPUTCHAN > 50 THEN INPUTCHAN ← INPUTCHAN - 100 ;
03500 INPUTSTR ← STRSCAN(LAST) ; LAST←LAST-2; RETURN(INPUTSTR) ;
03600 END "SWICHBACK" ;
03700
03800 INTERNAL SIMPLE PROCEDURE SWICHF(STRING FILENAME) ;
03900 BEGIN "SWICHF"
04000 INTEGER CHAN ; BOOLEAN MANEXT ;
04100 IFC TENEX THENC STRING ELSEC INTEGER ENDC FIR, EXT, PPN ; TES 10/25/73 ;
04200 IFC TENEX THENC DEFINE PUB=""".PUB""",PUG=""".PUG""",PUZ=""".PUZ""" ; ELSEC TES 10/25/73;
04300 DEFINE PUB = "'606542000000",
04400 PUG = "'606547000000",
04500 PUZ = "'606572000000";
04600 ENDC
04700 IF (CHAN ← GETCHAN) < 0 THEN
04800 BEGIN WARN("=","No channel for reading "&FILENAME) ; RETURN END ;
04900 CHANLS[CHAN] ← -1 ; EOF ← 0 ; OPEN(CHAN, "DSK", 0, 2, 0, 150, BRC, EOF) ;
05000 MANEXT ← FALSE ;
05100 FIR ← CVFIL(FILENAME, EXT, PPN) ;
05200 IF LAST=2 THEN
05300 BEGIN "PRIMARY FILE"
05400 MANEXT ← EXT=0 ;
05500 END "PRIMARY FILE" ;
05600 DO BEGIN
05700 IF MANEXT THEN FLAG ← NOT XLOOKUP(CHAN,FIR,PUB,0,PPN)
05800 ELSE LOOKUP(CHAN,FILENAME,FLAG);
05900 IF FLAG THEN IF MANEXT THEN MANEXT ← FALSE ELSE
06000 BEGIN
06100 OUTSTR("No file named `"&FILENAME&"'--read file:") ;
06200 FILENAME←INCHWL ;
06300 END ;
06400 END
06500 UNTIL ¬FLAG ;
06600 SWICH(NULL, CHAN, 0) ;
06700 IFC TENEX THENC IF EQU(EXT[1 FOR 4],PUG) OR EQU(EXT[1 FOR 4],PUZ) THEN
06800 ELSEC IF EXT=PUG OR EXT=PUZ THEN ENDC
06900 TECOFILE ← 0
07000 ELSE BEGIN INPUT(INPUTCHAN, NO_CHARS) ; TECOFILE ← BRC≥0 END ;
07100 PAGEMARKS ← PAGEWAS ← 1 ; SRCPAGE ← "1" ; SRCLINE ← IF TECOFILE THEN "0" ELSE "00000" ;
07200 IF TECOFILE THEN
07300 BEGIN COMMENT IF TVEDIT FILE, SKIP PAGE 1 ;
07400 IF EQU("COMMENT ⊗", INPUT(INPUTCHAN,TO_TERQ_CR)[1 TO 9]) THEN
07500 BEGIN
07600 DO INPUT(INPUTCHAN, TO_TB_FF_SKIP) UNTIL BRC=FF ;
07700 SRCPAGE ← "2" ; PAGEMARKS ← PAGEWAS ← 2 ;
07800 END
07900 ELSE BEGIN CLOSIN(INPUTCHAN) ; COMMENT NOT TVEDIT -- RESTART INPUT ;
08000 IF MANEXT THEN XLOOKUP(CHAN,FIR,PUB,0,PPN) ELSE
08100 LOOKUP(CHAN,FILENAME,FLAG);
08200 END END ;
08300 THISFILE ← FILENAME ;
08400 IF NOT PUBSTD THEN
08500 BEGIN
08600 IF LAST =4 AND SWFLG=0 THEN TES ADDED SWFLG 12/5/73 ;
08650 BEGIN OUTSTR("PUB: ") ; MAINFILE←THISFILE ; SWFLG ← 1 END
08700 ELSE OUTSTR(CRLF & SPS(LAST)) ;
08800 OUTSTR(THISFILE&SP&SRCPAGE) ; SWDBACK ← FALSE ;
08900 END ;
09000 END "SWICHF" ;
00100 INTERNAL BOOLEAN SIMPLE PROCEDURE SYMLOOK(STRING NAME) ;
00200 BEGIN "SYMLOOK" comment same as LOOKSYM, but if hash table full, expands it and does linear search ;
00300 comment don't search if it's already here;
00400 IF SYMBOL>0 AND EQU(SYM[SYMBOL],NAME) OR LOOKSYM(NAME) THEN RETURN(TRUE) ;
00500 IF SYMBOL>0 THEN RETURN(FALSE) ; comment it's not there, and table's not full;
00600 FOR SYMBOL ← SYMNO STEP 1 WHILE SYMBOL≤XSYMNO AND FULSTR(SYM[SYMBOL]) AND ¬EQU(SYM[SYMBOL],NAME) DO ;
00700 IF SYMBOL > XSYMNO THEN
00800 BEGIN
00900 SGROW(SYM, SYMIDA, XSYMNO, 1000, "Symbol Table Full") ; SMAKEBE(SYMIDA, SYM) ;
01000 ZEROSTRINGS(1000, SYM[XSYMNO-999]) ;
01100 GROW(NUMBER, NUMBIDA, DUMMY, 1000, NULL) ; MAKEBE(NUMBIDA, NUMBER) ;
01200 IF XSYMNO≥TWO(13) THEN WARN(NULL,"Symbol Table Enormopotamus. I give up.") ;
01300 FOR SYMBOL ← XSYMNO-999 THRU XSYMNO DO SYM[SYMBOL] ← NULL ;
01400 DUMMY←XSYMNO+1; SYMBOL ← XSYMNO - 999 ; RETURN(FALSE) ;
01500 END
01600 ELSE RETURN(FULSTR(SYM[SYMBOL])) ;
01700 END "SYMLOOK" ;
01800
01900 INTERNAL INTEGER SIMPLE PROCEDURE SYMNUM(STRING NAME) ;
02000 BEGIN "SYMNUM" comment looks up a symbol, and if not there, enters it. returns subscript;
02100 IF ¬SYMLOOK(NAME) THEN ENTERSYM(NAME, 0) ;
02200 RETURN(SYMBOL) ;
02300 END "SYMNUM" ;
02400
02500 INTERNAL BOOLEAN SIMPLE PROCEDURE SIMLOOK(STRING NAME) ;
02600 comment, SIMilar to SYMLOOK, but sets SYMTYPE and SYMIX ;
02700 IF SYMLOOK(NAME) THEN
02800 BEGIN
02900 BYTEWD ← NUMBER[SYMBOL] ;
03000 SYMTYPE ← LDB(TYPEWD(BYTEWD)) ; SYMIX ← LDB(IXWD(BYTEWD)) ;
03100 RETURN(TRUE) ;
03200 END
03300 ELSE RETURN(FALSE) ;
03400
03500 INTERNAL INTEGER SIMPLE PROCEDURE SIMNUM(STRING NAME) ;
03600 BEGIN "SIMNUM" comment, SIMilar to SYMNUM, but uses SIMLOOK instead of SYMLOOK ;
03700 IF ¬SIMLOOK(NAME) THEN ENTERSYM(NAME, SYMTYPE←SYMIX←0) ;
03800 RETURN(SYMBOL) ;
03900 END "SIMNUM" ;
04000
04100 INTERNAL INTEGER SIMPLE PROCEDURE WRITEON(BOOLEAN BINARY; STRING FILENAME) ;
04200 BEGIN "WRITEON"
04300 INTEGER CH ;
04400 IF (CH ← GETCHAN) < 0 THEN RETURN(WARN("=","No channel for writing "&FILENAME));
04500 K ← 0 ; OPEN(CH, "DSK", IF BINARY THEN 8 ELSE 0, 0, 2, DUMMY, DUMMY, K) ;
04600 ENTER(CH, FILENAME, DUMMY←0) ;
04700 IF DUMMY THEN WARN("=","ENTER failed for "&FILENAME);
04800 RETURN(CH) ;
04900 END "WRITEON" ;
00100 INTEGER SIMPLE PROCEDURE LOG2(INTEGER BINARY) ;
00200 BEGIN "LOG2"
00300 INTEGER I ; I ← 0 ;
00400 WHILE BINARY > 1 DO BEGIN I ← I + 1 ; BINARY ← BINARY DIV 2 END ;
00500 RETURN(I) ;
00600 END "LOG2" ;
00700
00800 INTEGER SVSHED ; comment, value of SHED before Alphabetizing began ;
00900 BOOLEAN SIMPLE PROCEDURE STRLSS(INTEGER XI, YI) ;
01000 BEGIN "STRLSS"
01100 INTEGER XL, YL, MINL, L ; STRING X, Y ;
01200 X ← SSTK[SVSHED + XI] ; Y ← SSTK[SVSHED + YI] ;
01300 XL ← LENGTH(X) ; YL ← LENGTH(Y) ; MINL ← XL MIN YL ;
01400 START_CODE "STRCOM"
01500 LABEL NEXC, SAME, DIFF ;
01600 MOVE 2, X ; MOVE 3, Y ; SKIPN 4, MINL ; JRST SAME ;
01700 NEXC: ILDB 5, 2 ; LDB 5, UPCAS5 ; ILDB 6, 3 ; LDB 6, UPCAS6 ;
01800 CAME 5, 6 ; JRST DIFF ; SOJG 4, NEXC ;
01900 SAME: COMMENT SAME FOR FIRST MINL CHARACTERS ;
02000 MOVE 5, XL ; MOVE 6, YL ; CAME 5, 6 ; JRST DIFF ;
02100 COMMENT AND SAME LENGTH: ; MOVE 5, XI ; MOVE 6, YI ;
02200 DIFF: CAML 5, 6 ; TDZA 1,1 ; MOVEI 1, -1 ; MOVEM 1, L ;
02300 END ;
02400 RETURN(L) ;
02500 END "STRLSS" ;
02600
02700 PROCEDURE QUICKERSORT(INTEGER J, BASE) ;
02800 BEGIN "QUICKERSORT" comment, Ascending SORT for ALFIZE ;
02900 INTEGER I, K, Q, M, P, T, X ; INTEGER ARRAY UT,LT[1:LOG2(J+2)+1] ;
03000 COMMENT Algorithm 271 (R. S. Scowen) CACM 8,11 (Nov. 1965) pp 669-670 ;
03100 DEFINE A(L) = "ITBL[BASE+L]" ;
03200 LABEL N, L, MM, PP ;
03300 I ← M ← 1 ;
03400 N: IF J-I > 1 THEN
03500 BEGIN
03600 P ← (J+I) DIV 2 ; T ← A(P) ; A(P) ← A(I) ; Q ← J ;
03700 FOR K ← I + 1 THRU Q DO
03800 BEGIN
03900 IF STRLSS(T, A(K)) THEN
04000 BEGIN
04100 FOR Q ← Q DOWN K DO
04200 BEGIN
04300 IF STRLSS(A(Q), T) THEN
04400 BEGIN
04500 A(K) ↔ A(Q) ; Q ← Q - 1 ;
04600 GO TO L ;
04700 END ;
04800 END ;
04900 Q ← K - 1 ;
05000 GO TO MM ;
05100 END ;
05200 L:
05300 END ;
05400 MM:
05500 A(I) ← A(Q) ; A(Q) ← T ;
05600 IF Q+Q > I+J THEN BEGIN LT[M]←I; UT[M]←Q-1; I←Q+1 END
05700 ELSE BEGIN LT[M]←Q+1; UT[M]←J; J←Q-1 END ;
05800 M ← M + 1 ;
05900 GO TO N ;
06000 END
06100 ELSE IF I≥J THEN GO TO PP
06200 ELSE BEGIN
06300 IF STRLSS(A(J),A(I)) THEN A(I)↔A(J) ;
06400 PP: M ← M - 1 ;
06500 IF M > 0 THEN BEGIN I←LT[M]; J←UT[M]; GO TO N END ;
06600 END ;
06700 END "QUICKERSORT" ;
00100 INTERNAL SIMPLE PROCEDURE DAPART ; IF ON THEN
00200 BEGIN "DAPART"
00300 DBREAK ; GLINEM ← 0 ; COMMENT ← TES 4/25/73 ; IF GROUPM=0 THEN RETURN ;
00400 IF MOLESIDA THEN DPB(0,BELOWM(OLX)) ; GROUPM←0 ;
00500 END "DAPART" ;
00600
00700 INTERNAL SIMPLE PROCEDURE MAKEPAGE(INTEGER HIGH, WIDE) ;
00800 BEGIN "MAKEPAGE"
00900 IDASSIGN("FRAMEIDA←CREATE(0,PFREC)", THISFRAME) ;
01000 HIGHF ← HIGH; WIDEF ← WIDE;
01100 END "MAKEPAGE" ;
01200
01300 INTERNAL SIMPLE PROCEDURE MAKEAREA(INTEGER ITSIX) ;
01400 BEGIN "MAKEAREA"
01500 INTEGER C, L, CS, LS, NCH, OCH ;
01600 IF FULWIDE(ITSIX) THEN
01700 BEGIN Comment Make frame width ;
01800 OCH ← CHARCT(ITSIX) ; CHARCT(ITSIX) ← NCH ← IF FRAMEIDA THEN WIDEF ELSE FWIDE ;
01900 COLWID(ITSIX) ← (COLWID(ITSIX) * NCH) DIV OCH ;
02000 END ;
02100 IF FULHIGH(ITSIX) THEN LINECT(ITSIX) ← IF FRAMEIDA THEN HIGHF ELSE FHIGH ;
02200 L←OPEN_ACTIVE(ITSIX)←CREATE(0, AREC) ;
02300 IF NULLAREAS THEN BEGIN IDASSIGN(AREAIDA←NULLAREAS,THISAREA) ; INA←LHRH(L,INA) END ;
02400 IDASSIGN(AREAIDA ← L, THISAREA) ;
02500 DEFA ← ITSIX ; STATA ← 0 ; INA ← LHRH(0, NULLAREAS) ; NULLAREAS ← AREAIDA ;
02600 IDASSIGN("AAA←CREATE2(1, CS←COLCT(ITSIX)*2, 0, LS←LINECT(ITSIX)+((LINECT(ITSIX) DIV 2) MAX 8) ) ", AA) ;
02700 ZEROWORDS(CS*(LS+1), AA[1,0]) ;
02800 COMMENT FOR C ← 1 THRU CS DO FOR L ← 0 THRU LS DO AA[C,L] ← 0 ;
02900 END "MAKEAREA" ;
03000
03100 FORWARD RECURSIVE PROCEDURE ASSUREAREA ;
03200
03300 INTERNAL SIMPLE PROCEDURE SEND(INTEGER PORTIX; STRING MESSAGE) ;
03400 BEGIN "SEND"
03500 INTEGER CH ;
03600 IF 0≤ (CH ← PORCH(PORTIX)) THEN OUT(CH,MESSAGE)
03700 ELSE IF CH=-1 THEN
03800 BEGIN ASSUREAREA ; CH←FOOTSTR(AREAIXM); SSTK[CH]←SSTK[CH]&MESSAGE END
03900 ELSE WARN(NULL,"Can't send to a passed PORTION:"&MESSAGE) ;
04000 END "SEND" ;
04100
04200 INTERNAL RECURSIVE PROCEDURE STATEMENT ;
04300 BEGIN "STATEMENT"
04400 INTEGER LVL ; BOOLEAN VALID ;
04500 LVL ← BLNMS ;
04600 DO VALID ← CHUNK(VALID) UNTIL BLNMS≤LVL ;
04700 END "STATEMENT" ;
00100 STRING SIMPLE PROCEDURE ALFIZE(STRING FILENAME, LEFTRIGHT) ;
00200 BEGIN "ALFIZE"
00300 INTEGER SVIHIGH, SVSHIGH, CHAN, LEFT, RIGHT, N, I ; STRING S, KEY ;
00400 SVSHED ← SHED ; SVIHIGH ← IHIGH ; SVSHIGH ← SHIGH ;
00500 IF (CHAN←GETCHAN)<0 THEN RETURN(WARN(NULL,"No Channel to Alphabetize "&FILENAME)) ;
00600 EOF ← 0 ; OPEN(CHAN, "DSK", 0, 2, 2, 150, BRC, EOF) ;
00700 LOOKUP(CHAN, FILENAME, FLAG) ; IF FLAG THEN RETURN(WARN("=","No Generated file "&FILENAME)) ;
00800 SETBREAK(LOCAL_TABLE, LEFTRIGHT&LF, NULL, "IS") ; LEFT ← LOP(LEFTRIGHT) ; RIGHT ← LOP(LEFTRIGHT) ; N ← 0 ;
00900 DO BEGIN "SENDEE"
01000 S ← INPUT(CHAN, TO_TB_FF_SKIP) ; IF EOF THEN DONE ; S ← S & TB ;
01100 DO S ← S & INPUT(CHAN, LOCAL_TABLE) UNTIL BRC=LEFT ∨ BRC=LF ∨ EOF ;
01200 IF BRC = LEFT THEN
01300 BEGIN "KEY"
01400 KEY ← NULL ; S ← S & LEFT ;
01500 DO KEY ← KEY & INPUT(CHAN, LOCAL_TABLE) UNTIL BRC=RIGHT OR BRC=LF OR EOF ;
01600 PUSHS(1,KEY) ; comment, Sort Key in SSTK ;
01700 S ← S & KEY ;
01800 IF BRC = RIGHT THEN
01900 BEGIN
02000 S ← S & RIGHT ;
02100 DO S ← S & INPUT(CHAN, LOCAL_TABLE) UNTIL BRC = LF OR EOF ;
02200 END ;
02300 END "KEY" ;
02400 PUTS(S&LF) ; comment, complete entry in STBL ;
02500 N ← N + 1 ; PUTI(1, N) ; comment, Sort Tags in ITBL ;
02600 END "SENDEE"
02700 UNTIL EOF ;
02800 QUICKERSORT(N, SVIHIGH) ;
02900 CLOSIN(CHAN) ; FILENAME ← FILENAME[1 TO ∞-1] & "Z" ;
03000 ENTER(CHAN, FILENAME, FLAG) ; comment, "---.PUZ" ;
03100 IF FLAG THEN RETURN(WARN(NULL,"ENTER failed for Alphabetized File "&FILENAME)) ;
03200 FOR I ← 1 THRU N DO OUT(CHAN, STBL[SVSHIGH + ITBL[SVIHIGH + I]]) ;
03300 RELEASE(CHAN) ; SHED ← SVSHED ; IHIGH ← SVIHIGH ; SHIGH ← SVSHIGH ; RETURN(FILENAME) ;
03400 END "ALFIZE" ;
03500
03600 INTERNAL SIMPLE PROCEDURE RECEIVE(INTEGER PORTIX; STRING ALPHABETIZE) ;
03700 BEGIN "RECEIVE"
03800 INTEGER CH ; STRING FIL ; LABEL TWICE ;
03900 CASE (CH ← PORCH(PORTIX)) + 6 MIN 6 OF
04000 BEGIN
04100 ie -6 ; GO TO TWICE ;
04200 ie -5 Only INSERTed ; IMPOSSIBLE("RECEIVE") ;
04300 ie -4 ; TWICE: WARN(NULL,"Already RECEIVEd generated file for this PORTION") ;
04400 ie -3 ; BEGIN "GENFILE"
04500 FIL ← CVSTR(PORFIL(PORTIX)) & ".PUG" & JOBNO ;
04600 IF FULSTR(ALPHABETIZE) THEN BEGIN FIL←ALFIZE(FIL,ALPHABETIZE) ; PORCH(PORTIX)←-6 END
04700 ELSE PORCH(PORTIX) ← -4 ;
04800 SWICHF(FIL) ; PAGESCAN(LAST) ← -PAGESCAN(LAST) ;
04900 END "GENFILE" ;
05000 ie -2 Never SENT ; BEGIN END ;
05100 ie -1 ; BEGIN CH←FOOTSTR(AREAIXM); SWICH(SSTK[CH],-1,0); SSTK[CH]←NULL END ;
05200 ie 0-15 ; IMPOSSIBLE("RECEIVE") ;
05300 END ;
05400 END "RECEIVE" ;
00100 INTERNAL SIMPLE PROCEDURE PLACE(INTEGER NEWAREAIX) ;
00200 COMMENT If No Place Area, AREAIXM=0. AREAIDA≠0 if STATUS= 0 or 1 ;
00300 IF ON THEN
00400 BEGIN "PLACE"
00500 INTEGER FRM, ALLOW_FOR, MARGIX, FONTIX ;
00600 IF IXTYPE(NEWAREAIX)≠AREATYPE THEN
00700 BEGIN WARN("=","PLACE in non-area"); NEWAREAIX←IXTEXT END;
00800 IF AREAIXM THEN
00900 BEGIN TES 11/19/73 ;
01000 TFONT(AREAIXM) ← THISFONT ;
01100 OFONT(AREAIXM) ← OLDFONT ;
01200 END ;
01300 IF AREAIDA ∧ STATUS=1 THEN
01400 BEGIN
01500 COLA ← COL ; AA[COL,0] ← LHRH(COVERED,LINE) ; AA[PAL,0]←LHRH(COVERED,PINE) ; STATA←STATUS ;
01600 XGENA ← XGENLINES; RKJ;
01700 OVERA ← OVEREST ; TES 11/15/73;
01800 IF AREAIXM=NEWAREAIX THEN RETURN
01900 ELSE IF COL>COLS THEN BEGIN WARN("=","Can't PLACE inside footnotes!") ; RETURN END ;
02000 END ;
02100 IF XCRIBL AND AREAIXM NEQ NEWAREAIX THEN
02200 BEGIN INTEGER DUMMY ;TES 11/15/73 ;
02300 THISFONT ← TFONT(NEWAREAIX) ; OLDFONT ← OFONT(NEWAREAIX) ;
02400 IF (DUMMY←FONTFIL[THISFONT])>0 THEN MAKEBE(DUMMY, CW) ;
02500 END ;
02600 AREAIXM←NEWAREAIX ;
02700 IF (AREAIDA ← OPEN_ACTIVE(AREAIXM)) = 0 THEN MAKEAREA(AREAIXM)
02800 ELSE BEGIN MAKEBE(AREAIDA, THISAREA) ; IDASSIGN(AAA, AA) ; END ;
02900 IF (MARGIX ← MARGINS(AREAIXM)) = 0 THEN BEGIN LMARG ← 0 ; RMARG ← COLWID(AREAIXM) END
03000 ELSE BEGIN LMARG ← LMARGX(MARGIX) ; RMARG ← RMARGX(MARGIX) END ;
03100 ALLOW_FOR ← 2 * COLWID(AREAIXM) ;
03200 IF ALLOW_FOR > LENGTH(OWL) THEN OWL ← OWL&SPS(ALLOW_FOR - LENGTH(OWL)) ;
03300 COLS ← COLCT(AREAIXM) ; LINES ← LINECT(AREAIXM) ; STATUS ← STATA ;
03400 IF STATUS=1 THEN
03500 BEGIN "IT'S OPEN"
03600 COL ← COLA ; PAL ← (COL+COLS-1) MOD (2*COLS) + 1 ; ie, Leg↔Foot;
03700 LINE ← AA[COL,0] ; COVERED ← LH(LINE) ; LINE ← RH(LINE) ; PINE ← RH("AA[PAL,0]") ;
03800 XGENLINES ← XGENA; RKJ;
03900 OVEREST ← OVERA ; TES 11/15/73 ;
04000 END "IT'S OPEN"
04100 ELSE COL←PAL←LINE←COVERED←PINE←XGENLINES←OVEREST←0 ; RKJ ADDED XGENLINES;
04200 TES ADDED OVEREST 11/15/73;
04300 END "PLACE" ;
04400
04500
04600 INTEGER PROCEDURE FIND_CHR(INTEGER CHR) ; COMMENT ADDED 2/20/73 TES ;
04700 BEGIN "FIND_CHR"
04800 INTEGER I, B ;
04900 FOR I ← LENGTH(DEFN_BRC)-LDEFN_BRC STEP -1 UNTIL 1 DO
05000 IF DEFN_BRC[I FOR 1] = CHR THEN
05100 BEGIN B ← I ; DONE END ;
05200 RETURN(B) ;
05300 END "FIND_CHR" ;
05400
05500
05600 INTERNAL SIMPLE PROCEDURE TURN(INTEGER CHR,FUN,ONOFF) ;
05700 BEGIN "TURN"
05800 INTEGER CODE, X, M, STDCHR ; BOOLEAN HADCHR, DEFD ; LABEL FIN ;
05900 DEFD ← FALSE ; CODE ← LDB(SPCODE(CHR)) ; STDCHR ← LDB(SPCHAR(FUN)) ;
06000 IF CHR=TB THEN
06100 BEGIN
06200 DPB(TABTAB ← IF ONOFF THEN FUN ELSE 0, SPCODE(CHR)) ;
06300 GO TO FIN ;
06400 END
06500 ELSE IF ¬CODE THEN HADCHR ← FALSE
06600 ELSE IF CODE=STDCHR AND ONOFF THEN GO TO FIN COMMENT ALREADY ON ;
06700 ELSE IF ¬ONOFF ∨ ¬STDCHR THEN
06800 BEGIN COMMENT REMOVE CHARACTER FROM BREAK TABLE STRING ;
06900 HADCHR ← TRUE ; X ← LENGTH(TEXT_BRC) ;
07000 START_CODE "FINDIT"
07100 LABEL NEXC, DUN ;
07200 MOVE 1, TEXT_BRC ; SKIPN 2, X ; JRST DUN ;
07300 NEXC: ILDB 3,1 ; CAMN 3, CHR ; JRST DUN ; SOJG 2, NEXC ;
07400 DUN: MOVEM 2, M ;
07500 END ;
07600 TEXT_BRC ← TEXT_BRC[1 TO X-M] & TEXT_BRC[X-M+2 TO X] ;
07700 END ;
07800 IF ONOFF THEN
07900 BEGIN "ON" COMMENT REV. 2/20/73 TES ;
08000 IF STDCHR ∧ STDCHR < LBRACK THEN TEXT_BRC ← TEXT_BRC & CHR ;
08100 IF FUN="{" ∧ ¬FIND_CHR(CHR) THEN
08200 BEGIN
08300 DEFN_BRC ← CHR & DEFN_BRC ;
08400 DEFD ← TRUE ;
08500 END ;
08600 DPB(STDCHR, SPCODE(CHR)) ;
08700 END "ON"
08800 ELSE BEGIN "OFF" COMMENT REV. 2/20/73 TES ;
08900 INTEGER I ;
09000 IF FUN = "{" ∧ (I ← FIND_CHR(CHR)) THEN
09100 BEGIN
09200 DEFN_BRC ← DEFN_BRC[1 TO I-1] & DEFN_BRC[I+1 TO ∞] ;
09300 DEFD ← TRUE ;
09400 END ;
09500 IF HADCHR THEN DPB(0, SPCODE(CHR)) ;
09600 END "OFF" ;
09700 SETBREAK(TEXT_TBL, TEXT_BRC&SIG_BRC, NULL, "IS") ;
09800 IF DEFD THEN SETBREAK(DEFN_TABLE, DEFN_BRC, NULL, "IS") ;
09900 FIN:
10000 IF ONOFF ≤ 0 THEN ISTK[PUSHI(TURNWDS, TURNTYPE) - 1] ←
10100 CHR LSH 7 LOR (IF CHR=TB THEN CODE ELSE CHARSP[CODE FOR 1]) ;
10200 END "TURN" ;
00100 INTERNAL SIMPLE PROCEDURE BEGINBLOCK(BOOLEAN MIDPGPH; INTEGER ECASE ; STRING NAME) ;
00200 BEGIN "BEGINBLOCK"
00300 INTEGER MIX, I, X ;
00400 IF ECASE = 0 THEN STARTS ← STARTS + 1 comment START...END ;
00500 ELSE IF ECASE=-1 THEN ENDCASE←1 comment, ONCE merging with BEGIN ;
00600 ELSE BEGIN "NOT CLUMP"
00700 DBREAK ; DEPTH ← DEPTH + 1 ; MIX ← PUSHI(MODEWDS, MODETYPE) ;
00800 ARRBLT(ISTK[MIX-MODEWDS], BREAKM, MODEWDS) ;
00900 PUSHI(28, TABTYPE) ; I ← 0 ;
01000 DO ISTK[MIX←MIX+1] ← X ← TABSORT[I←I+1] UNTIL X=TWO(33) ;
01100 ISTK[MIX+1] ← ISTK[IHED] ; OLDIHED ← IHED;TES 11/15/73; IHED ← MIX + 1 ;
01200 IF MIDPGPH THEN
01300 BEGIN "SAVE FILL PARAMS"
01400 X ← MIDWDS + 1 ; PUSHI(X, MIDTYPE) ;
01500 ILBF ← CVASC(LBF) ; ARRBLT(ISTK[IHED-X], THISTYPE, X-1) ;
01600 ISTK[IHED-1]←PUSHS(1, THISWD) ; NOPGPH ← TRUE ; PLBL←BRKPLBL←-TWO(13) ;
01700 END "SAVE FILL PARAMS" ;
01800 ENDCASE ← ECASE ; STARTS ← 0 ;
01900 END "NOT CLUMP" ;
02000 IF BLNMS=MAXBLNMS THEN WARN(NULL, "DEEP BLOCK NEST/POSSIBLY INFINITE RECURSION");
02100 IF NAME ≠ ALTMODE THEN BLKNAMES[BLNMS←BLNMS+1] ← NAME ; comment not for ONCE! ;
02200 END "BEGINBLOCK" ;
02300
02400 INTERNAL BOOLEAN SIMPLE PROCEDURE FINDINSET(INTEGER HM) ;
02500 BEGIN "FINDINSET"
02600 INTEGER ARE ;
02700 LLSCAN(LEADRESPS, NEXT_RESP, "(ARE ← CLUE(LLTHIS)) ≥ HM" ) ;
02800 RETURN(LLTHIS ∧ ARE = HM) ;
02900 END "FINDINSET" ;
03000
03100 INTERNAL INTEGER SIMPLE PROCEDURE FINDSIGNAL(INTEGER SIGASC) ;
03200 BEGIN "FINDSIGNAL"
03300 INTEGER CHR ;
03400 CHR ← SIGASC LSH -29 ;
03500 LLSCAN(SIGNALD[CHR], NEXT_RESP, "SIGASC = SIGNAL(LLTHIS)" ) ;
03600 RETURN(LLTHIS) ;
03700 END "FINDSIGNAL" ;
03800
03900 INTERNAL INTEGER SIMPLE PROCEDURE FINDTRAN(INTEGER UASYMB, VARI) ;
04000 BEGIN "FINDTRAN"
04100 LLSCAN(WAITRESP, NEXT_RESP, "CLUE(LLTHIS) = UASYMB ∧ (VARI=0 ∨ VARIETY(LLTHIS)=VARI)" ) ;
04200 RETURN(LLTHIS) ;
04300 END "FINDTRAN" ;
04400
04500 INTERNAL SIMPLE PROCEDURE COMPMAXIMS ;
04600 BEGIN "COPYMAXIMS"
04700 FMAXIM ← (RMARG-RIGHTIM)-LMARG ;
04800 NMAXIM ← COLWID(IF AREAIXM THEN AREAIXM ELSE IXTEXT)-LMARG ;
04900 MAXIM ← IF FILL THEN FMAXIM ELSE NMAXIM ;
05000 END "COPYMAXIMS" ;
05100
05200 INTERNAL SIMPLE PROCEDURE BIND(INTEGER LOC, NEWIX) ;
05300 BEGIN "BIND"
05400 IF LOC = SYMTEXT THEN IXTEXT ← NEWIX
05500 ELSE IF LOC = SYMPAGE THEN BEGIN IXPAGE ← NEWIX ; PATPAGE ← PATT_STRS(IXPAGE) END ;
05600 DPB(NEWIX, IXN(LOC)) ; IF LDB(TYPEN(LOC)) ≥ 11 THEN DPB(LOC, BIXNUM(NEWIX)) ;
05700 END "BIND" ;
00100 INTERNAL RECURSIVE BOOLEAN PROCEDURE ENDBLOCK ;
00200 IF BLNMS<0 ∧ LAST>2 THEN BEGIN WARN("=","Extra END ignored"); BLNMS←0; RETURN(FALSE) END ELSE
00300 BEGIN "ENDBLOCK"
00400 INTEGER TYP, OLD, MIX, I, X, L1, L2, PASSED, NARROWED ; STRING S ;
00500 DBREAK ; NARROWED ← PASSED ← FALSE ;
00600 DO COMMENT Skip through ISTK restoring former state and terminating INDENT etc. ;
00700 BEGIN "ISTK ENTRY"
00800 TYP ← IXTYPE(IHED) ;
00900 CASE TYP - 12 OF
01000 BEGIN COMMENT BY TYPE ;
01100 [AREATYPE-12] IF ¬DISD(IHED) THEN BEGIN CLOSEAREA(IHED,TRUE) ; NUMBER[LDB(BIXNUM(IHED))]←0 END;
01200 [UNITTYPE-12] IF ¬DISD(IHED) THEN BEGIN CLOSEUNIT(IHED,TRUE) ; NUMBER[LDB(BIXNUM(IHED))]←0 END;
01300 [MACROTYPE-12] BEGIN SSTK[BODY(IHED)]←NULL;TES 11/15/73; NUMBER[LDB(BIXNUM(IHED))] ← 0 END;
01400 [RESPTYPE-12] BEGIN "POP RESP"
01500 X ← CLUE(IHED) ; I ← VARIETY(IHED) ; OLD ← OLD_RESP(IHED) ;
01600 SSTK[BODY(IHED)] ← NULL ; TES 11/15/73 ;
01700 CASE I-1 MIN 2 OF
01800 BEGIN "BY VARIETY"
01900 ie 0 ... Phrase ;
02000 TES 11/15/73 removed this case ;
02100 ie 1 ... Inset ;
02200 IF FINDINSET(X) THEN
02300 IF ¬OLD THEN LLSKIP(LEADRESPS, NEXT_RESP)
02400 ELSE BEGIN
02500 NEXT_RESP(OLD) ← LLPOST ;
02600 IF LLPREV<0 THEN LEADRESPS←OLD ELSE NEXT_RESP(LLPREV) ← OLD ;
02700 END ;
02800 ie 2 ... Signal ;
02900 BEGIN "SIGNAL"
03000 X ← SIGNAL(IHED) ; L1 ← X LSH -29 ;
03100 IF FINDSIGNAL(X) THEN
03200 IF ¬OLD THEN BEGIN
03300 S ← NULL ;
03400 WHILE FULSTR(SIG_BRC) ∧ (L2←LOP(SIG_BRC))≠L1 DO S←S&L2;
03500 SIG_BRC ← S & SIG_BRC ;
03600 LLSKIP("SIGNALD[L1]", NEXT_RESP) ; COMMENT JAN 8 1973 ;
03700 END
03800 ELSE BEGIN
03900 NEXT_RESP(OLD) ← LLPOST ;
04000 IF LLPREV<0 THEN SIGNALD[L1]←OLD ELSE NEXT_RESP(LLPREV) ← OLD ;
04100 END ;
04200 END "SIGNAL" ;
00100 ie 3, 4 ... After, Before ;
00200 IF FINDTRAN(X,I) THEN
00300 IF ¬OLD THEN LLSKIP(WAITRESP, NEXT_RESP)
00400 ELSE BEGIN
00500 NEXT_RESP(OLD) ← LLPOST ;
00600 IF LLPREV<0 THEN WAITRESP←OLD ELSE NEXT_RESP(LLPREV) ← OLD ;
00700 END ;
00800 END "BY VARIETY" ;
00900 END "POP RESP" ;
01000 [MARGTYPE-12] IF OLD←AREAX(IHED) THEN
01100 BEGIN NARROWED ← TRUE ; MARGINS(OLD) ← X ← OLD_MARGX(IHED) ;
01200 LMARG ← IF X THEN LMARGX(X) ELSE 0 ;
01300 RMARG ← IF X THEN RMARGX(X) ELSE COLWID(OLD) ;
01400 END ;
01500 [TURNTYPE-12] IF (OLD←ISTK[IHED-1])≥0 THEN TURN(OLD LSH -7 , OLD LAND '177 , 1 ) ;
01600 [MODETYPE-12] BEGIN
01700 I ← GROUPM ; OLD ← AREAIXM ; X ← GLINEM ; TES 11/15/73 REMOVED J ← THISFONT ;
01800 ARRBLT(BREAKM, ISTK[IHED-MODEWDS], MODEWDS) ; OLD ↔ AREAIXM ;
01900 TES 11/14/73 removed IF J ≠ THISFONT THEN SELECTFONT(THISFONT);
02000 IF I THEN IF ¬GROUPM THEN DAPART
02100 ELSE IF GLINEM=0 THEN GLINEM ← X ;
02200 COMMENT ADDED THIS ↑ LINE 2/20/73 ;
02300 IF ¬PASSED ∧ NARROWED THEN NOPGPH ← 1 ;
02400 JUSTIFY ← FILL ∧ ADJUST ∨ JUSTJUST ;
02500 PLACE(IF OLD THEN OLD ELSE IXTEXT);
02600 COMPMAXIMS ;
02700 END ;
02800 [NUMTYPE-12] BEGIN
02900 OLD ← OLD_NUMBER(IHED) ;
03000 NUMBER[X ← LDB(SYMBOLWD(OLD))] ← OLD ;
03100 IF X = SYMPAGE THEN BEGIN IXPAGE ← LDB(IXN(X)) ; PATPAGE ← PATT_STRS(IXPAGE) END
03200 ELSE IF X = SYMTEXT THEN IXTEXT ← LDB(IXN(X)) ;
03300 END ;
03400 [TABTYPE-12] BEGIN
03500 MIX ← IXOLD(IHED) ; I ← 0 ;
03600 DO TABSORT[I←I+1] ← X ← ISTK[MIX←MIX+1] UNTIL X=TWO(33) ;
03700 END ;
03800 [MIDTYPE-12] BEGIN
03900 IF LENGTH(INPUTSTR)>1 THEN WARN("Imbalance","Unbalanced Response|Footnote! "&SOMEINPUT) ;
04000 THISWD←SSTK[ISTK[IHED-1]] ; OLD←PLBL ;
04100 ARRBLT(THISTYPE,ISTK[X←IXOLD(IHED)+1],IHED-X-1) ;
04200 LBF ← CVSTR(ILBF) ;
04300 WHILE FULSTR(LBF) ∧ LBF[∞ FOR 1]=0 DO LBF←LBF[1 TO ∞-1] ;
04400 IF OLD ≠ -TWO(13) THEN
04500 BEGIN COMMENT UNDEFINED PAGE LABELS -- PASS UP TO OUTER BLOCK ;
04600 X ← OLD ;
04700 DO BEGIN L1←X ; X←IF X<0 THEN NUMBER[-X] ELSE ITBL[X] END UNTIL X=-TWO(13) ;
04800 IF L1<0 THEN NUMBER[-L1] ← PLBL ELSE ITBL[L1] ← PLBL ;
04900 PLBL ← OLD ;
05000 END ;
05100 INPUTSTR←NULL ; IF THATISFULL THEN RDENTITY ELSE INPUTSTR←SWICHBACK ; PASSED←TRUE ;
05200 END ;
05300 [FONTYPE-12] IF (OLD←AREAX(IHED)) AND XCRIBL THEN TES 11/15/73 ;
05400 BEGIN
05500 FONTS(OLD) ← OUTERX(IHED) ;
05600 TFONT(OLD) ← THISFONTX(IHED) ;
05700 OFONT(OLD) ← OLDFONTX(IHED) ;
05800 IF OLD = AREAIXM THEN
05900 BEGIN
06000 THISFONT ← TFONT(OLD) ;
06100 OLDFONT ← OFONT(OLD) ;
06200 IDASSIGN("FONTFIL[THISFONT]", CW) ;
06300 END ;
06400 END ;
06450 [PITYPE-12] PICHAR[PIKEY(IHED)] ← SSTK[PIVAL(IHED)] TES 11/29/73;
06500 END ; COMMENT BY TYPE ;
06600 IHED ← IXOLD(IHED) ;
06700 END "ISTK ENTRY"
06800 UNTIL TYP=MODETYPE ∨ IHED=0 ;
06900 DEPTH ← DEPTH - 1 ;
07000 RETURN(PASSED) ;
07100 END "ENDBLOCK" ;
00100 RECURSIVE PROCEDURE TOEND ;
00200 BEGIN "TOEND"
00300 BOOLEAN VALID ;
00400 VALID ← TRUE ;
00500 DO VALID ← CHUNK(VALID) UNTIL MYEND ;
00600 MYEND ← FALSE ;
00700 END "TOEND" ;
00800
00900 INTERNAL SIMPLE PROCEDURE ANYEND(BOOLEAN CHECK) ;
01000 BEGIN "ANYEND"
01100 STRING BLOCKNAME ;
01200 BLOCKNAME ← IF BLNMS<0 THEN "!MISSING!" ELSE BLKNAMES[BLNMS] ;
01300 BLNMS ← (BLNMS MAX 0) - 1 ;
01400 IF CHECK ∧ THATISCON THEN
01500 BEGIN
01600 PASS ;
01700 LOPP(THISWD) ;
01800 IF ¬ITSV(BLOCKNAME) THEN WARN("Mismatched BEGIN-END","BEGIN """&BLOCKNAME&""" but END """&THISWD&"""") ;
01900 END
02000 ELSE IF FULSTR(BLOCKNAME) THEN WARN("Mismatched BEGIN-END","BEGIN """&BLOCKNAME&""" but END <blank>") ;
02100 END "ANYEND" ;
02200
02300 INTERNAL RECURSIVE PROCEDURE BEGINEND ;
02400 BEGIN ANYEND(TRUE) ; IF ENDBLOCK THEN WARN("=","Missed END in Response|Footnote") ELSE PASS END ;
02500
02600 INTERNAL RECURSIVE PROCEDURE ONCEEND ;
02700 IF ENDBLOCK THEN WARN("=","Missing END in Response|Footnote") ELSE BEGINEND ;
02800
02900 INTERNAL RECURSIVE PROCEDURE STARTEND ;
03000 BEGIN ANYEND(TRUE) ; STARTS ← STARTS - 1 ; PASS ; END ;
03100
03200 INTERNAL RECURSIVE PROCEDURE RESPOND(INTEGER IX) ;
03300 IF ON THEN
03400 BEGIN "RESPOND"
03500 INTEGER ARGS ; STRING COM_ENT ;
03600 ARGS ← IF VARIETY(IX) = 2 THEN NUMARGS(IX) ELSE 0 ;
03700 IF VARIETY(IX) < 3 ∧ IX ≠ SIGNALD[FF] THEN
03800 BEGIN "AT"
03900 SWICH(IF IX=SIGNALD[CR] THEN SSTK[BODY(IX)] ELSE ALTMODE&SSTK[BODY(IX)]&RCBRAK, -1, ARGS) ;
04000 RETURN ;
04100 END "AT" ;
04200 GENSYM←GENSYM+1 ; COM_ENT ← "!?@"&CVS(GENSYM) ;
04300 BEGINBLOCK( TRUE, 3 , COM_ENT ) ;
04400 SWICH(SSTK[BODY(IX)]&(CRLF&TB&TB&"END """)&COM_ENT&""";;", -1, ARGS) ;
04500 PASS ; TOEND ;
04600 END "RESPOND" ;
04700
04800 INTERNAL RECURSIVE PROCEDURE RESPEND ;
04900 BEGIN ANYEND(TRUE) ; PASS ; IF ENDBLOCK THEN MYEND←TRUE ELSE WARN("=","Extra END") ; END ;
00100 INTERNAL SIMPLE PROCEDURE OPENFRAME ;
00200 BEGIN "OPENFRAME"
00300 MAKEPAGE(FHIGH,FWIDE);
00400 OLXX ← OLMAX ; comment Total of all areas now declared ; OLX ← 0 ;
00500 IDASSIGN("OWLSF←OWLSIDA←CREATE(0,OLXX)", OWLS);
00600 IDASSIGN("MOLESF←MOLESIDA←CREATE(0,OLXX)", MOLES);
00700 IDASSIGN("SHORTF←SHORTIDA←CREATE(0,OLXX)", SHORT);
00800 END "OPENFRAME" ;
00900
01000 INTERNAL SIMPLE PROCEDURE OPENPAGE ;
01100 DO BEGIN OPENFRAME ; IDASSIGN(OLDPGIDA ← FRAMEIDA, OLDPAGE) ;
01200 PAGEVAL ← PATT_VAL(PATPAGE) ;
01300 IF FINDTRAN(SYMPAGE, 4) THEN RESPOND(LLTHIS) ;
01400 END UNTIL FRAMEIDA ;
01500
01600 SIMPLE PROCEDURE REMNULLS ;
01700 BEGIN "REMNULLS"
01800 INTEGER L, R, I ;
01900 L ← LH(INA) ; R ← RH(INA) ;
02000 IF L ∨ R THEN
02100 BEGIN
02200 I ← AREAIDA ;
02300 IF L THEN BEGIN IDASSIGN(AREAIDA←L,THISAREA); DPB(R, H2(INA)) ; END ELSE NULLAREAS ← R ;
02400 IF R THEN BEGIN IDASSIGN(AREAIDA←R,THISAREA); DPB(L, H1(INA)) ; END ;
02500 IDASSIGN(AREAIDA ← I, THISAREA) ;
02600 END
02700 ELSE NULLAREAS ← 0 ;
02800 END "REMNULLS" ;
02900
03000 INTERNAL RECURSIVE PROCEDURE OPENAREA(INTEGER ITSIX) ;
03100 BEGIN "OPENAREA"
03200 INTEGER X, PREV, NEX ;
03300 IF FRAMEIDA=0 THEN OPENPAGE ; PLACE(ITSIX) ; IF STATUS=1 THEN RETURN ; REMNULLS ;
03400 INA ← FRAMEIDA ;
03500 PREV ← 0 ; NEX ← ARF ; X ← AREAIDA ; COMMENT KEEP AREAS SORTED BY LEFT EDGE ;
03600 IF CHAR1(ITSIX) > 1 THEN WHILE NEX DO
03700 BEGIN
03800 IF NEX=X THEN
03900 BEGIN COMMENT PREVENT INEXPLICABLE ENDLESS LOOP 2/27/73 TES;
04000 WARN("CAN'T REOPEN", "CAN'T REOPEN CLOSED AREA " &
04100 SYM[LDB(BIXNUM(ITSIX))] ) ;
04200 RETURN ;
04300 END ;
04400 IDASSIGN(AREAIDA←NEX, THISAREA) ;
04500 IF DEFA THEN IF CHAR1("DEFA") ≥ CHAR1(ITSIX) THEN DONE ELSE BEGIN END
04600 ELSE BEGIN IDASSIGN(AAA,AA) ; IF AA[1,0]≥CHAR1(ITSIX) THEN DONE ; END ;
04700 PREV ← AREAIDA ; NEX ← ARA ;
04800 END ;
04900 IF PREV THEN
05000 BEGIN TES AND DCS REVISED 9/24/73@SU, 10/25/73@PARC ;
05100 IDASSIGN(AREAIDA←PREV, THISAREA) ; TES ADDED THIS ;
05200 ARA ← X ;
05300 END
05400 ELSE ARF ← X ;
05500 IDASSIGN(AREAIDA←X, THISAREA) ; ARA ← NEX ;
05600 STATA ← STATUS←1 ; COL ← 1 ; PAL ← COLS + 1 ;
05700 IF FINDTRAN(LDB(BIXNUM(ITSIX)), 4) THEN RESPOND(LLTHIS) ; comment BEFORE areaname ... ;
05800 END "OPENAREA" ;
00100 INTERNAL RECURSIVE PROCEDURE CLOSET(INTEGER ITSIX; BOOLEAN CLOSEIT, DISDECLAREIT) ;
00200 BEGIN "CLOSET"
00300 IF DISDECLAREIT THEN DBREAK ;
00400 IF FINDTRAN(LDB(BIXNUM(ITSIX)), 3) THEN
00500 IF CLOSEIT ∧ ITSIX≠IXPAGE ∧ comment AFTER ;
00600 (IXTYPE(ITSIX)=AREATYPE ∨ FULSTR("CTR_VAL(""PATT_STRS(ITSIX)"")")) THEN RESPOND(LLTHIS) ;
00700 IF DISDECLAREIT THEN DISD(ITSIX) ← -1 ;
00800 END "CLOSET" ;
00900
01000 INTERNAL RECURSIVE PROCEDURE CLOSEAREA(INTEGER ITSIX; BOOLEAN DISDECLAREIT) ;
01100 BEGIN "CLOSEAREA"
01200 INTEGER SAVAR, C, WC, NC, CC, LEFC ; BOOLEAN NORESP ;
01300 NORESP ← ITSIX < 0 ; ITSIX ← ABS(ITSIX) ;
01400 IF DISDECLAREIT THEN OLMAX ← OLMAX - LINECT(ITSIX)*COLCT(ITSIX) ;
01500 IF OPEN_ACTIVE(ITSIX) = 0 THEN IF DISDECLAREIT THEN CLOSET(ITSIX, FALSE, TRUE)
01600 ELSE BEGIN END
01700 ELSE BEGIN SAVAR←AREAIXM; PLACE(ITSIX); IF STATUS=0 THEN REMNULLS ; STATA ← STATUS←2;
01800 ULLA ← LINE1(ITSIX) ; AA[1,0] ← LEFC ← CHAR1(ITSIX) ;
01900 IF (NC ← COLCT(ITSIX)) > 1 THEN
02000 BEGIN
02100 WC ← COLWID(ITSIX) ; CC ← CHARCT(ITSIX) ;
02200 FOR C ← 2 THRU NC DO AA[C,0] ← LEFC + ((C-1)*(CC-WC)) DIV (NC-1) ;
02300 END ;
02400 LINECA ← LINECT(ITSIX) ; COLCA ← NC ;
02500 IF ¬NORESP THEN CLOSET(ITSIX, TRUE, DISDECLAREIT) ;
02600 IF DISDECLAREIT THEN BEGIN STATA ← STATUS←3 ; DEFA ← 0 END ;
02700 OPEN_ACTIVE(ITSIX) ← AREAIDA ← 0 ;
02800 IF SAVAR ∧ ¬DISDECLAREIT ∧ SAVAR ≠ ITSIX THEN PLACE(SAVAR) ELSE BEGIN AREAIXM←0; STATUS←-1 END ;
02900 END ;
03000 END "CLOSEAREA" ;
03100
03200 INTERNAL RECURSIVE PROCEDURE CLOSEUNIT(INTEGER ITSIX; BOOLEAN DISDECLAREIT) ;
03300 BEGIN "CLOSEUNIT"
03400 INTEGER STRS, PP ;
03500 CLOSET(ITSIX, TRUE, DISDECLAREIT) ;
03600 IF DISDECLAREIT THEN
03700 BEGIN
03800 IF (PP ← PARENT(ITSIX)) THEN
03900 BEGIN
04000 LLSCAN("SON(PP)", BROTHER, LLTHIS=ITSIX) ;
04100 LLSKIP("SON(PP) ", BROTHER) ;
04200 END ;
04300 STRS ← PATT_STRS(ITSIX) ;
04400 PATT_VAL(STRS)←PREFIX(STRS)←INFIX(STRS)←SUFFIX(STRS)←CTR_VAL(STRS)←NULL ;
04500 IF STRS=SHED THEN SHED←SHED-5 ;
04600 END ;
04700 END "CLOSEUNIT" ;
00100 INTERNAL SIMPLE PROCEDURE DISDECLARE(INTEGER SYMB, OLDTYPE, OLDIX) ;
00200 IF ON THEN
00300 CASE OLDTYPE OF
00400 BEGIN
00500 [LOCALTYPE] BEGIN SSTK[OLDIX]←NULL; IF IX=SHED THEN SHED←SHED-1 END ;
00600 [INTERNTYPE] WARN("=",SYM[SYMB]&" Redeclared") ;
00700 [AREATYPE] CLOSEAREA(OLDIX,TRUE);
00800 [UNITTYPE] CLOSEUNIT(OLDIX,TRUE) ;
00900 [14]
01000 END ;
01100
01200 INTERNAL INTEGER SIMPLE PROCEDURE DECLARE(INTEGER LOC, NEWTYPE) ;
01300 IF ON THEN
01400 BEGIN "DECLARE"
01500 INTEGER NEWDEPTH, OLDDEPTH ; LABEL PURGE ;
01600 BYTEWD ← NUMBER[LOC] ;
01700 NEWDEPTH ← CASE NEWTYPE OF (0,1,DEPTH,0,DEPTH,0,0,0,0,0,1,DEPTH,DEPTH,DEPTH,DEPTH) ;
01800 IF LOC = SYMTEXT ∧ NEWTYPE ≠ AREATYPE ∨ LOC = SYMPAGE ∧ NEWTYPE ≠ UNITTYPE THEN
01900 BEGIN
02000 WARN("=",SYM[LOC] & " may only be type " & (IF LOC=SYMTEXT THEN "AREA" ELSE "UNIT")) ;
02100 GO TO PURGE ;
02200 END ;
02300 IF LDB(TYPEWD(BYTEWD)) THEN
02400 IF (OLDDEPTH ← LDB(DEPTHWD(BYTEWD))) < 1 THEN
02500 BEGIN
02600 WARN("=","YOU MAY NOT REDECLARE RESERVED WORD " & SYM[LOC]) ;
02700 PURGE: LOC ← SYMNUM("(Purged)" & SYM[LOC]) ;
02800 END
02900 ELSE IF OLDDEPTH < NEWDEPTH THEN
03000 BEGIN
03100 PUSHI(NUMWDS, NUMTYPE) ;
03200 OLD_NUMBER(IHED) ← BYTEWD ;
03300 END
03400 ELSE IF OLDDEPTH = 1 THEN
03500 BEGIN
03600 WARN("=","YOU MAY NOT REDECLARE" & SYM[LOC] & ", A GLOBAL VARIABLE OR PORTION") ;
03700 GO TO PURGE ;
03800 END
03900 ELSE IF OLDDEPTH=NEWDEPTH THEN
04000 DISDECLARE(LOC, LDB(TYPEWD(BYTEWD)), LDB(IXWD(BYTEWD)))
04100 ELSE WARN("=","GLOBAL " & SYM[LOC] & " REDECLARING LOCAL") ;
04200 NUMBER[LOC] ← (NEWDEPTH ROT -5) LOR (LOC LSH 18) LOR (NEWTYPE LSH 14) ;
04300 RETURN(LOC) ;
04400 END "DECLARE" ;
00100 INTERNAL STRING SIMPLE PROCEDURE VASSIGN(INTEGER VSYMB, VTYPE, VIX; STRING VAL) ;
00200 BEGIN "VASSIGN" comment, NAME←VAL ;
00300 SIMPLE PROCEDURE RDONLY(STRING IV) ; WARN("=","The value of "&IV&" is read-only") ;
00400 IF ON THEN CASE VTYPE OF
00500 BEGIN COMMENT BY TYPE ;
00600 [0] BIND(VSYMB←DECLARE(VSYMB, GLOBALTYPE), PUTS(VAL)) ; ie Undeclared identifier ;
00700 [GLOBALTYPE] STBL[VIX] ← VAL ;
00800 [LOCALTYPE] SSTK[VIX] ← VAL ;
00900 [INTERNTYPE] CASE VIX OF
01000 BEGIN COMMENT INTERNAL ;
01100 ie 0 ... LINES ; RDONLY("LINES") ;
01200 ie 1 ... COLUMNS; RDONLY("COLUMNS") ;
01300 ie 2 ... ! ; ! ← VAL ;
01400 ie 3 ... SPREAD ; SPREADM ← CVD(VAL) ;
01500 ie 4 ... FILLING; RDONLY("FILLING") ;
01600 ie 5 ... _SKIP_ ; MANUS_SKIP_ ← CVD(VAL) ;
01700 ie 6 ... _SKIPL_; DPB(CVD(VAL), H1(MANUS_SKIP_)) ;
01800 ie 7 ... _SKIPR_; DPB(CVD(VAL), H2(MANUS_SKIP_)) ;
01900 ie 8 ... NULL ; RDONLY("NULL") ;
02000 ie 9 ... ∞ ; RDONLY("∞") ;
02100 ie 10... FOOTSEP; FOOTSEP ← VAL ;
02200 ie 11... TRUE ; RDONLY("TRUE") ;
02300 ie 12... FALSE ; RDONLY("FALSE") ;
02400 ie 13... INDENT1; FIRSTIM ← CVD(VAL) ;
02500 ie 14... INDENT2; RESTIM ← CVD(VAL) ;
02600 ie 15... INDENT3; BEGIN RIGHTIM ← CVD(VAL) ; COMPMAXIMS END ;
02700 ie 16... LMARG ; BEGIN LMARG ← CVD(VAL) MAX 0 MIN
02800 COLWID(IF AREAIXM THEN AREAIXM ELSE IXTEXT)-1 ; COMPMAXIMS END ;
02900 ie 17... RMARG ; BEGIN RMARG ← CVD(VAL) MAX 1 MIN
03000 COLWID(IF AREAIXM THEN AREAIXM ELSE IXTEXT) ; COMPMAXIMS END ;
03100 ie 18... CHAR ; RDONLY("CHAR") ;
03200 ie 19... CHARS ; RDONLY("CHARS") ;
03300 ie 20... LINE ; RDONLY("LINE") ;
03400 ie 21... COLUMN ; RDONLY("COLUMN") ;
03500 ie 22... TOPLINE; RDONLY("TOPLINE") ;
03600 ie 23... XCRIBL ; RDONLY("XCRIBL") ;
03700 ie 24... CHARW ; CHARW ← CVD(VAL) ;
03800 ie 25... XGENLINES; XGENLINES ← CVD(VAL) ;
03900 ie 26... UNDERLINE ; VUNDERLINE ← VAL ; TES 10/22/73 ;
04000 ie 27... THISDEVICE ; RDONLY("DEVICE") ; TES 11/15/73
04100 ie 28... THISFONT ; RDONLY("THISFONT") ; TES 11/15/73 ;
04130 ie 29... FOOTGAP ; FOOTGAP ← CVD(VAL) ; TES 11/29/73 ;
04160 ie 30... FOOTSEPFONT ; FSFONT ← RFONT(VAL) ; TES 11/29/73 ;
04190 ie 31... TTY ; OUTSTR(CRLF & VAL & CRLF) ; TES 11/29/73 ;
04200 END ; COMMENT INTERNAL ;
04300 [MANTYPE] WARN("Improper use of `←'","← after reserved word "&SYM[VSYMB]&" -- assignment ignored") ;
04400 [PORTYPE] WARN("=","← after PORTION NAME "&SYM[VSYMB]) ;
04500 [PUNITTYPE] PATT_VAL("PATT_STRS(VIX)") ← VAL ;
04600 [AREATYPE] WARN("=","← after Area NAME "&SYM[VSYMB]) ;
04700 [UNITTYPE] CTR_VAL("PATT_STRS(VIX)") ← VAL
04800 END ; COMMENT BY TYPE ;
04900 RETURN(VAL) ;
05000 END "VASSIGN" ;
05100
05200 INTERNAL SIMPLE PROCEDURE ASSIGN(STRING NAME, VAL) ;
05300 VASSIGN(SIMNUM(NAME), 0, SYMIX, VAL) ;
05400
05500 INTERNAL SIMPLE PROCEDURE NOPORTION ;
05600 BEGIN "NOPORTION"
05700 STRING IFIL ; INTEGER PIX ;
05800 WARN("=","No PORTION Declaration Found") ;
05900 IFIL ← "PUI"&CVS(INTERS←INTERS+1) ; THISPORT ← PIX ← PUTI(4, -2) ;
06000 PORINT(PIX) ← CVASC(IFIL) ; PORSEQ(SEQPORT) ← PIX ; PORSEQ(SEQPORT←PIX) ← 0 ;
06100 PORTS ← PORTS + 1 ; INTER ← WRITEON(TRUE, IFIL & ".PUI") ; SINTER ← WRITEON(FALSE, IFIL & "S.PUI") ;
06200 END "NOPORTION" ;
00100 STRING SIMPLE PROCEDURE CVALF(INTEGER ALFABET, VAL) ;
00200 BEGIN "CVALF" COMMENT handles 1aAiI conversions ;
00300 STRING S, A ; INTEGER I ;
00400 PRELOAD_WITH NULL, "i", "ii", "iii", "iv", "v", "vi", "vii", "viii", "ix",
00500 NULL, "x", "xx", "xxx", "xl", "l", "lx", "lxx", "lxxx", "xc",
00600 NULL, "c", "cc", "ccc", "cd", "d", "dc", "dcc", "dccc", "cm" ;
00700 OWN STRING ARRAY LOWROMAN[0:2, 0:9] ;
00800 PRELOAD_WITH NULL, "I", "II", "III", "IV", "V", "VI", "VII", "VIII", "IX",
00900 NULL, "X", "XX", "XXX", "XL", "L", "LX", "LXX", "LXXX", "XC",
01000 NULL, "C", "CC", "CCC", "CD", "D", "DC", "DCC", "DCCC", "CM" ;
01100 OWN STRING ARRAY UPROMAN[0:2, 0:9] ;
01200 DEFINE BEG = "WHILE VAL DO BEGIN", OOPS = "WARN(""="",""I only know roman numerals upto 1000, sorry"")" ;
01300 IF VAL = 0 THEN RETURN("0") ;
01400 IF VAL<0 THEN BEGIN S ← "-" ; VAL ← ABS(VAL) END ELSE S ← NULL ;
01500 A ← NULL ; I ← -1 ;
01600 CASE ALFABET - 1 OF
01700 BEGIN
01800 ie 1 ... "1" ; A ← CVS(VAL) ;
01900 ie 2 ... "i" ; IF VAL < 1000 THEN BEG A ← LOWROMAN[I←I+1, VAL MOD 10]&A ;
02000 VAL← VAL DIV 10 END ELSE OOPS ;
02100 ie 3 ... "I" ; IF VAL < 1000 THEN BEG A ← UPROMAN[I←I+1, VAL MOD 10]&A ;
02200 VAL← VAL DIV 10 END ELSE OOPS ;
02300 ie 4 ... "a" ; BEG A ← ("a" + (VAL-1) MOD 26)&A ; VAL ← VAL DIV 26 END ;
02400 ie 5 ... "A" ; BEG A ← ("A" + (VAL-1) MOD 26)&A ; VAL ← VAL DIV 26 END ;
02500 END ;
02600 RETURN(S & A) ;
02700 END "CVALF" ;
02800
02900 INTEGER SIMPLE PROCEDURE CHRSALF(INTEGER INT, ALFABET) ;
03000 BEGIN "CHRSALF"
03100 INTEGER LABS, LSIGN ; STRING STR ; PRELOAD_WITH [2]3,2,[5]1,[2]0 ; OWN INTEGER ARRAY L[0:9] ;
03200 LSIGN ← IF INT < 0 THEN 1 ELSE 0 ; INT ← ABS(INT) ; STR ← CVS(INT) ;
03300 CASE ALFABET DIV 2 OF
03400 BEGIN
03500 ie 1 ... "1" ; LABS ← LENGTH(STR) ;
03600 ie 2 ... i,I ; LABS ← 4*LENGTH(STR) - L[STR-"0"] ; comment, Believe-it-or-Not ;
03700 ie 3 ... a,A ; LABS ← LENGTH(CVALF(ALFABET, INT)) ;
03800 END ;
03900 RETURN(LABS + LSIGN) ;
04000 END "CHRSALF" ;
04100
04200 SIMPLE PROCEDURE FIXFRAME(INTEGER FRIDA) ;
04300 BEGIN "FIXFRAME"
04400 IF AREAIDA ∧ STATUS=1 THEN PLACE(AREAIXM) ; COMMENT BE SURE LINE,PINE STORED IN AA ;
04500 MOLES[0] ← OLX ;
04600 IDASSIGN(FRAMEIDA ← FRIDA, THISFRAME) ;
04700 IDASSIGN("OWLSIDA ← OWLSF", OWLS) ;
04800 IDASSIGN("MOLESIDA ← MOLESF", MOLES) ;
04900 IDASSIGN("SHORTIDA ← SHORTF", SHORT) ;
05000 OLX ← MOLES[0] ; AREAIDA ← 0 ;
05100 END "FIXFRAME" ;
05200
05300 INTERNAL INTEGER SIMPLE PROCEDURE NEWBLANK(INTEGER MOLE) ;
05400 BEGIN MOLES[OLX←OLX+1]←MOLE ; OWLS[OLX]←0 ; RETURN(OLX); END "NEWBLANK";
05500
05600 SIMPLE INTEGER PROCEDURE TOPMOST(INTEGER COLNO, LINO) ;
05700 BEGIN TES 12/6/73 USED BY PLACELINE FOR GLINEM IN FOOT ;
05800 WHILE LINO>1 AND (LDB(ABOVEM("AA[COLNO,LINO]")) OR LDB(BELOWM("AA[COL,LINO-1]"))) DO
05900 LINO ← LINO - 1 ;
06000 RETURN(AA[COLNO,LINO]) ;
06100 END "TOPMOST" ;
06200
06300 SIMPLE STRING PROCEDURE ENOUGH(STRING STR ; INTEGER WID, F) ;
06400 BEGIN TES 11/29/73 enough of STR to extend WID charws in font F ;
06500 INTEGER WASF, N, X ; STRING S2 ;
06600 WASF ← THISFONT ; S2 ← STR ;
06700 IDASSIGN("FONTFIL[F]", CW) ; X ← WID * CHARW ; N ← 0 ;
06800 WHILE FULSTR(S2) AND X GEQ 0 DO
06900 BEGIN N←N+1 ; X ← X-CW[LOP(S2)] END ;
07000 IF X<0 THEN N ← N-1 ;
07100 IDASSIGN("FONTFIL[WASF]", CW) ;
07200 RETURN(STR[1 TO N]) ;
07300 END ;
00100 INTERNAL PROCEDURE FINPAGE ;
00200 BEGIN "FINPAGE" COMMENT ***T EMPO RA RY V ERS I ON -- No Boxes **** ;
00300 INTEGER A, CS, LS, C, L, X, LB, LBPAGE, LINK, LINENO, FOOTLINE1, F, OWLINE, ARIX ;
00400 INTEGER NULINE, NUPINE, NUINE, NLFOOT, NPFOOT, NFOOT, NAREA ;
00500 IF EXNEXTPAGE THEN BEGIN WARN("=","Response to PAGE change called NEXT PAGE again.") ; RETURN END ;
00600 EXNEXTPAGE ← TRUE ;
00700 BEGIN "PAGEOUT"
00800 COMMENT PASS 1 OUTPUT FORMAT FOR EACH PAGE :
00900 Height Width
01000 For each area:
01100 UpperLine NumCols NumLines
01200 For each column:
01300 LeftChar
01400 For each non-null line: LineNo SHORTM Index of PUInS.PUI line
01500 0
01600 -10
01700 ;
01800 IF OLDPGIDA ≠ FRAMEIDA THEN BEGIN WARN("=","FRAME≠PAGE at end of page"); FIXFRAME(OLDPGIDA) END ;
01900 IF AREAIDA ∧ AREAIXM ∧ STATUS=1 THEN CLOSEAREA(AREAIXM, FALSE) ;
02000 IF (A ← ARF) THEN
02100 BEGIN "NONEMPTY"
02200 INTEGER ARRAY XTRALINES[1:HIGHF]; RKJ TO FIXUP "TOPLINES" OF AREAS;
02300 IF INTER ≤ 0 THEN NOPORTION ;
02400 LS←0;
02500 WHILE A DO BEGIN "COLLECTXGENS"
02600 IDASSIGN(AREAIDA←A, THISAREA) ; A ← ARA ; IDASSIGN(AAA, AA) ;
02700 IF STATA THEN LS ← LS + (XTRALINES[ULLA MAX 1] ← XGENA);
02800 END "COLLECTXGENS";
02900 A←ARF;
03000 WORDOUT(INTER, HIGHF+LS) ; WORDOUT(INTER, WIDEF) ;
03100 WHILE A DO BEGIN "AFTER AREA RESPONSES"
03200 IDASSIGN(AREAIDA←A, THISAREA) ; A ← ARA ; IDASSIGN(AAA, AA) ;
03300 IF (X ← DEFA) ∧ STATA=1 ∧ FINDTRAN(LDB(BIXNUM(X)), 3) THEN RESPOND(LLTHIS) ;
03400 END "AFTER AREA RESPONSES" ;
03500 A ← ARF ;
03600 WHILE A DO BEGIN "CLOSE ALL AREAS"
03700 IDASSIGN(AREAIDA←A, THISAREA) ; A ← ARA ; IDASSIGN(AAA, AA) ;
03800 IF STATA = 1 THEN CLOSEAREA(-DEFA, FALSE) ;
03900 END "CLOSE ALL AREAS" ;
04000 A ← ARF ;
04100 WHILE A DO
04200 BEGIN "AREAOUT"
04300 IDASSIGN(AREAIDA←A, THISAREA) ; NAREA ← 0 ; IDASSIGN(AAA, AA) ;
00100 IF STATA > 1 THEN
00200 BEGIN "AREAUSED" TES CHANGED X TO ARIX 12/5/73 ;
00300 IF GRPOLX ∧ (STATUS←STATA)=2 ∧ (ARIX ← DEFA) THEN
00400 BEGIN COMMENT SET UP GROUP OVERFLOW INFO ;
00500 FIXFRAME(NEWPGIDA) ; OPENAREA(ARIX) ; NAREA ← AREAIDA ;
00600 IDASSIGN(AAA, NAA) ; NLFOOT←NPFOOT←NULINE←NUPINE←0 ;
00700 FIXFRAME(OLDPGIDA) ; IDASSIGN(AREAIDA←A, THISAREA) ;
00800 IDASSIGN(AAA, AA) ;
00900 END ;
01000 CS ← COLCA ; LS ← LINECA + XGENA ; RKJ ADDED XGENA;
01100 F←0; RKJ;
01200 FOR C←1 THRU ULLA-1 DO F←F+XTRALINES[C]; RKJ SEE IF ANY AREAS ABOVE THIS ONE HAVE "XTRALINES";
01300 WORDOUT(INTER, ULLA+F) ; RKJ ADDED F; WORDOUT(INTER, CS) ; WORDOUT(INTER, LS) ;
01400 FOR C ← 1 THRU CS DO
01500 BEGIN "AREACOL" WORDOUT(INTER, AA[C,0]) ; FOOTLINE1 ← LS - RH("AA[CS+C,0]") ;
01600 FOR F ← 0, CS DO FOR L ← 1 THRU LS DO IF (X ← AA[F+C, L]) THEN
01700 IF GRPOLX = 0 ∨ X < GRPOLX ∨ X > GRPTOP THEN
01800 BEGIN "AREALINE" LINENO ← IF F=0 THEN L ELSE FOOTLINE1 + L ;
01900 IF (LB ← LDB(LABELM(X))) THEN
02000 BEGIN "A PAGE LABEL"
02100 LBPAGE ← 2 ROT -2 LOR PUTS(PAGEVAL&(IF XCRIBL THEN ALTMODE&CVS(XLENGTH(PAGEVAL)) ELSE NULL)) ;
02200 WHILE LB ≠ -TWO(13) DO
02300 IF (LINK ← LB) < 0 THEN
02400 BEGIN
02500 LB←NUMBER[-LINK] ;
02600 NUMBER[-LINK] ← LBPAGE ;
02700 END
02800 ELSE BEGIN LB←ITBL[LINK] ; ITBL[LINK]←LBPAGE END ;
02900 END "A PAGE LABEL" ;
03000 IF OWLINE ← OWLS[X] THEN BEGIN WORDOUT(INTER, LINENO) ;
03100 WORDOUT(INTER, SHORT[X]) ; WORDOUT(INTER, OWLINE) END ;
03200 END "AREALINE"
03300 ELSE BEGIN "GRP OVERFLOW"
03303 IF F AND NUPINE=0 THEN TES 11/5/73 ;
03306 BEGIN "FOOTSP"
03309 FOR NUPINE←1 THRU FOOTGAP DO
03312 NAA[F+1,NUPINE] ←
03315 NEWBLANK(IF NUPINE=1 THEN BLW ELSE ABV_BLW) ;
03318 NAA[F+1,NUPINE]←NOLX←NOLX+1 ;
03321 NOWLS[NOLX] ← OWLSEQ ← OWLSEQ+1 ;
03324 IF XCRIBL THEN
03327 OUT(SINTER,CVSR(OWLSEQ)&ALTMODE&
03330 PICKFONT(FSFONT)&ENOUGH(FOOTSEP,COLWID(AREAIXM),FSFONT)&CRLF)
03333 ELSE
03336 OUT(SINTER, CVSR(OWLSEQ) & ALTMODE &
03339 FOOTSEP[1 TO COLWID(ARIX)] & CRLF) ;
03342 NMOLES[NOLX] ← IF FOOTGAP=0 THEN BLW ELSE ABV_BLW ;
03345 END "FOOTSP" ;
03400 NUINE ← IF F THEN NUPINE ← NUPINE + 1 ELSE NULINE ← NULINE + 1 ;
03500 NFOOT ← IF LDB(FOOTM(X)) = 0 THEN 0
03600 ELSE IF F THEN NPFOOT←NPFOOT+1 ELSE NLFOOT←NLFOOT+1 ;
03700 NAA[F+1, NUINE] ← NOLX ← NOLX + 1 ; NOWLS[NOLX] ← OWLS[X] ;
03800 IF NFOOT THEN DPB(NFOOT, FOOTM(X)) ; NMOLES[NOLX] ← MOLES[X] ;
03900 NSHORT[NOLX] ← SHORT[X] ;
04000 END "GRP OVERFLOW" ;
04100 WORDOUT(INTER, 0) ;
04200 END "AREACOL" ;
04300 END "AREAUSED" ;
04400 A ← ARA ;
04500 GOAWAY(WHATIS(AA)) ; GOAWAY(AREAIDA) ;
04600 IF NAREA THEN
04700 BEGIN
04800 NAA[1, 0] ← NULINE ; NAA[CS+1, 0] ← NUPINE ;
04900 IDASSIGN(AREAIDA←NAREA, THISAREA) ; COLA ← 1 ; AREAIDA ← 0 ;
05000 END ;
05100 END "AREAOUT" ;
05200 WORDOUT(INTER, -10) ;
05300 END "NONEMPTY" ;
05400 GOAWAY(MOLESIDA) ; GOAWAY(SHORTIDA) ; GOAWAY(-1 LSH 18 + OWLSIDA) ;
05500 MOLESIDA ← SHORTIDA ← OWLSIDA ← GROUPM ← GLINEM ← 0 ;
05600 GOAWAY(FRAMEIDA) ; FRAMEIDA ← OLDPGIDA ← AREAIDA ← 0 ; STATUS ← -1 ;
05700 END "PAGEOUT" ;
05800 IF GRPOLX THEN GRPOLX ← 0 ;
05900 EXNEXTPAGE ← FALSE ;
06000 OVEREST ← 0; comment short font kludge ;
06100 END "FINPAGE" ;
00100 INTERNAL RECURSIVE PROCEDURE USTEP(INTEGER USYMB, UIX) ;
00200 BEGIN "USTEP"
00300 INTEGER PS, PARIX, PARTYPE, SONIX, SONPS, IVAL, SVTY, SVIX, SVSY, SVTHAT ;
00400 INTEGER I;
00500 STRING PARVAL, CVAL, PVAL, SVWD ;
00600 IF UIX>0 ∧ ¬IN_LINE(UIX) THEN DBREAK ;
00700 IF UIX>0 ∧ FULSTR("CTR_VAL(""PATT_STRS(UIX)"")") ∧ FINDTRAN(USYMB, 3) THEN RESPOND(LLTHIS) ;
00800 IF UIX = IXPAGE AND OLDPGIDA THEN FINPAGE ELSE UIX ← ABS(UIX) ;
00900 PS ← PATT_STRS(UIX) ; CVAL ← CTR_VAL(PS) ;
01000 CTR_VAL(PS) ← CVAL ←
01100 CVS(IVAL←IF NULSTR(CVAL) THEN CTR_INIT(UIX)-TWO(14) ELSE CVD(CVAL)+CTR_STEP(UIX)-TWO(6)) ;
01200 PARVAL ← IF PATT_PARENT(UIX) ∧ (PARIX ← PARENT(UIX)) THEN
01300 EVALV("(a parent unit)", PARIX, PUNITTYPE) ELSE NULL ;
01400 IF PATT_ALF(UIX) THEN
01500 PVAL ← ! ← PREFIX(PS)&PARVAL&INFIX(PS)&CVALF(PATT_ALF(UIX),IVAL)&SUFFIX(PS)
01600 ELSE BEGIN
01700 SVTY←THISTYPE ; SVIX←IX ; SVSY←SYMB ; SVWD←THISWD ; SVTHAT←THATISFULL ;
01800 SWICH(PREFIX(PS), -1, 0) ; PASS ; PVAL ← E(NULL, NULL) ;
01900 PASS ; IF ITS(;) THEN PASS ;
02000 IF ¬ITS(!!!) THEN WARN("=","Unbalanced COUNT Template") ;
02100 SWICHBACK ;
02200 THISTYPE←SVTY ; IX←SVIX ; SYMB←SVSY ; THISWD←SVWD ;
02300 IF SVTHAT THEN RDENTITY ELSE EMPTYTHAT;
02400 END ;
02500 IF LENGTH(CVAL) > CTR_CHRS(UIX) THEN
02600 BEGIN
02700 WARN("Counter underestimated","Underestimated counter "&SYM[USYMB]&" -- reached "&CVAL) ;
02800 CTR_CHRS(UIX) ← LENGTH(CVAL) ;
02900 END ;
03000 IF LENGTH(PVAL) > PATT_CHRS(UIX) THEN
03100 BEGIN
03200 IF PATT_STRS(UIX) THEN WARN("Pattern underestimate",
03300 "Underestimated unit "&SYM[USYMB]&": -- reached "&PVAL) ;
03400 PATT_CHRS(UIX) ← LENGTH(PVAL) ;
03500 END ;
03600 PATT_VAL(PS) ← PVAL ; SONIX ← SON(UIX) ;
03700 WHILE SONIX > 0 DO
03800 BEGIN
03900 SONPS ← PATT_STRS(SONIX) ;
04000 IF SONIX≠IXPAGE ∧ FULSTR("CTR_VAL(SONPS)") ∧ FINDTRAN(LDB(BIXNUM(SONIX)),3) THEN RESPOND(LLTHIS) ;
04100 CTR_VAL(SONPS) ← PATT_VAL(SONPS) ← NULL ;
04200 IF SONIX = IXPAGE THEN USTEP(SYMPAGE, SONIX ← -SONIX) ;
04300 DO SONIX ← IF SONIX>0 ∧ (K←SON(SONIX)) THEN K ELSE IF (K←BROTHER(ABS SONIX)) THEN K
04400 ELSE -PARENT(ABS SONIX) UNTIL SONIX>0 ∨ SONIX=-UIX ;
04500 END ;
04600 IF UIX ≠ IXPAGE ∧ FINDTRAN(USYMB, 4) THEN RESPOND(LLTHIS) ;
04700 IF UIX = IXPAGE THEN PAGEVAL ← PATT_VAL(PATPAGE) ;
04800 ! ← PVAL ; C! ← CVAL ; comment RESPOND or USTEP(..PAGE..) might have changed it ;
04900 END "USTEP" ;
05000
05100 INTERNAL SIMPLE PROCEDURE NEXTPAGE ;
05200 BEGIN
05300 INTEGER SAVEAREA ;
05400 SAVEAREA ← IF AREAIXM THEN LDB(BIXNUM(AREAIXM)) ELSE SYMTEXT ;
05500 USTEP(SYMPAGE, IXPAGE) ;
05600 PLACE(LDB(IXN(SAVEAREA))) ;
05700 END ;
05800
05900 SIMPLE PROCEDURE OWT(STRING C) ;
06000 BEGIN "OWT"
06100 IF NULSTR(C) THEN BEGIN OWLS[OLX] ← 0 ; RETURN END ;
06200 IF INTER ≤ 0 THEN NOPORTION ;
06300 OWLS[OLX] ← OWLSEQ ← OWLSEQ + 1 ;
06400 OUT(SINTER, CVSR(OWLSEQ) & C) ;
06500 END "OWT" ;
00100 INTERNAL PROCEDURE CREUNIT(INTEGER INLINE, PFROM, PTO, PBY, PIN;
00200 STRING PPRINTING; INTEGER USYMB) ;
00300 BEGIN "CREUNIT"
00400 INTEGER TEMP, LENPAT, PARENTCHARS, POSNALF, POSN!, PS, ALF, UIX, PINIX, PINPS, PCHARS ;
00500 STRING S!, SPAR, SPAR! ;
00600 USYMB ← DECLARE(USYMB, UNITTYPE) ; TEMP ← DECLARE(SYMNUM(SYM[USYMB]&"!"), PUNITTYPE) ;
00700 UIX ← PUSHI(UNITWDS, UNITTYPE) ; PS ← PUSHS(5, NULL) ; PATT_STRS(UIX) ← PS ;
00800 BIND(USYMB, UIX) ; DPB(UIX, IXN(TEMP)) ;
00900 CTR_INIT(UIX) ← PFROM + TWO(14) ; CTR_STEP(UIX) ← PBY + TWO(6) ;
01000 TES 10/25/73 ; IN_LINE(UIX) ← IF UIX=IXPAGE THEN 0 ELSE INLINE ;
01100 PINIX ← IF PIN THEN LDB(IXN(PIN)) ELSE 0 ; PARENT(UIX) ← PINIX ;
01200 IF PIN = 0 THEN PARENTCHARS ← PINPS ← 0
01300 ELSE IF LDB(TYPEN(PIN)) = UNITTYPE THEN
01400 BEGIN
01500 PARENTCHARS ← PATT_CHRS(PINIX) ; PINPS ← PATT_STRS(PINIX) ;
01600 BROTHER(UIX) ← SON(PINIX) ; SON(PINIX) ← UIX ;
01700 END
01800 ELSE BEGIN WARN("=","Undeclared Parent Unit "&SYMB) ; PINPS ← 0 ; PARENTCHARS ← 2 END ;
01900 PCHARS ← LENGTH(CVS(PFROM)) MAX LENGTH(CVS(PTO)) ;
02000 IF FULSTR(PPRINTING) ∧ PPRINTING=0 THEN
02100 BEGIN "TEMPLATE"
02200 PREFIX(PS) ← "!←" & PPRINTING[2 TO ∞] & ";!!!;;" ;
02300 PATT_ALF(UIX) ← 0 ;
02400 IF PIN≠0 ∧ PINPS=0 THEN TEMP ← PCHARS + PARENTCHARS comment lousy guess ;
02500 ELSE BEGIN
02600 S! ← ! ; CTR_VAL(PS) ← CVS(PTO - PBY) ; CTR_CHRS(UIX)←PATT_CHRS(UIX)←1000 ;
02700 IF PINPS THEN BEGIN SPAR ← CTR_VAL(PINPS) ; SPAR! ← PATT_VAL(PINPS) ;
02800 CTR_VAL(PINPS) ← "999999"[1 TO CTR_CHRS(PINIX)] ;
02900 PATT_VAL(PINPS) ← ! ← "9999999999999999"[1 TO PARENTCHARS] ; END ;
03000 USTEP(USYMB, -UIX) ; TEMP ← LENGTH(!) ;
03100 ! ← S! ; IF PINPS THEN BEGIN CTR_VAL(PINPS) ← SPAR ; PATT_VAL(PINPS) ← SPAR! END ;
03200 END ;
03300 END "TEMPLATE"
03400 ELSE BEGIN "PATTERN"
03500 STRING PATCOPY ; LABEL FALF ; INTEGER ARRAY PCH[1:LENGTH(PPRINTING)] ;
03600 PRELOAD_WITH "1", "i", "I", "a", "A" ; OWN INTEGER ARRAY ALFS[1:5] ;
03700 PATCOPY ← PPRINTING ; LENPAT ← 0 ; WHILE FULSTR(PATCOPY) DO PCH[LENPAT←LENPAT+1]←LOP(PATCOPY) ;
03800 FOR POSNALF ← LENPAT DOWN 1 DO FOR ALF ← 1 THRU 5 DO IF ALFS[ALF]=PCH[POSNALF] THEN GO TO FALF;
03900 WARN("=","No 1, i, I, a, or A in pattern for "&SYM[SYMB]) ;
04000 POSNALF ← LENPAT + 1 ; PPRINTING ← PPRINTING & "1" ;
04100 FALF: POSN! ← POSNALF - 1 ; WHILE POSN! ∧ PCH[POSN!]≠"!" DO POSN! ← POSN! - 1 ;
04200 PATT_ALF(UIX) ← ALF ; PATT_PARENT(UIX) ← IF POSN! THEN 1 ELSE 0 ;
04300 PREFIX(PS) ← PPRINTING[1 TO POSN!-1] ; INFIX(PS) ← PPRINTING[POSN!+1 TO POSNALF-1] ;
04400 SUFFIX(PS) ← PPRINTING[POSNALF+1 TO ∞] ; PATT_VAL(PS) ← NULL ;
04500 TEMP ← LENGTH(PREFIX(PS)) + PARENTCHARS + LENGTH(INFIX(PS)) +
04600 (CHRSALF(PFROM,ALF) MAX CHRSALF(PTO,ALF)) + LENGTH(SUFFIX(PS));
04700 END "PATTERN" ;
04800 PATT_CHRS(UIX) ← TEMP ; CTR_CHRS(UIX) ← PCHARS ; PATT_VAL(PS)←CTR_VAL(PS)←NULL ;
04900 END "CREUNIT" ;
00100 RECURSIVE PROCEDURE ASSUREAREA ;
00200 IF AREAIDA = 0 ∨ STATUS ≠ 1 THEN OPENAREA(IF AREAIXM THEN AREAIXM ELSE IXTEXT) ;
00600
00700 RECURSIVE BOOLEAN PROCEDURE MOVEGROUP(BOOLEAN OFFPAGE ; INTEGER TOCOL, TOLINE, EXTRA) ;
00800 BEGIN "MOVEGROUP"
00900 INTEGER SAVEAREA, LFOOT, PFOOT, FOOL, C, L, L1, L2, F, TC, TL, X ;
01000 IF ¬OFFPAGE THEN
01100 IF COL≤COLS<TOCOL ∨ TOCOL>2*COLS THEN BEGIN OFFPAGE←TRUE ; TOCOL ← IF COL>COLS THEN COLS+1 ELSE 1 END ;
01200 IF OFFPAGE THEN
01300 BEGIN "OTHER PAGE"
01400 SAVEAREA ← IF AREAIXM THEN LDB(BIXNUM(AREAIXM)) ELSE SYMTEXT ;
01500 GRPTOP ← OLX ; GRPOLX ← GLINEM ; GLINEM ← 0 ; CLOSEAREA(AREAIXM, FALSE) ;
01600 MOLES[0]←OLX ; OPENFRAME ; IDASSIGN(NEWPGIDA←FRAMEIDA, NEWPAGE) ;
01700 IDASSIGN("MOLESF", NMOLES) ; IDASSIGN("SHORTF", NSHORT) ; SIDASSIGN("OWLSF", NOWLS) ;
01800 NOLX ← OLX ; FIXFRAME(OLDPGIDA) ;
01900 USTEP(SYMPAGE,IXPAGE) ; NMOLES[0]←NOLX ; NSHORT[0]←NOLX ;
02000 FIXFRAME(NEWPGIDA) ; IDASSIGN(OLDPGIDA←NEWPGIDA, OLDPAGE) ;
02100 F ← ARF ;
02200 WHILE F DO
02300 BEGIN
02400 IDASSIGN(AREAIDA←F, THISAREA) ; F ← ARA ;
02500 IF (X ← DEFA) THEN
02600 BEGIN OLD_ACTIVE(X)←NEW_ACTIVE(X); NEW_ACTIVE(X)←0 END ;
02700 END ;
02800 NEWPGIDA ← 0 ; OPENAREA(LDB(IXN(SAVEAREA))) ;
03000 IF FINDTRAN(SYMPAGE,4) THEN RESPOND(LLTHIS) ;
03050 IF TOCOL > COLS THEN BEGIN COL ↔ PAL ; LINE ↔ PINE END ;
03100 END "OTHER PAGE"
03200 ELSE BEGIN "SAME PAGE"
03300 GRPOLX ← GLINEM ; LFOOT ← 0 ; FOOL ← IF PAL>COL THEN PINE ELSE LINE ;
03400 PFOOT ← IF FOOL=0 THEN 0 ELSE IF LDB(FOOTM("AA[PAL MAX COL,FOOL]"))=31 THEN 30 ELSE 0;
03500 FOR C ← COL, PAL DO
03600 BEGIN
03700 L1 ← 1 ; L2 ← IF C = COL THEN LINE ELSE PINE ;
03800 TC ← IF C=COL THEN TOCOL ELSE (TOCOL+COLS-1) MOD (2*COLS) + 1 ;
03900 TL ← IF C=COL THEN TOLINE-1 ELSE RH("AA[TC,0]") ;
04000 F ← IF C ≤ COLS THEN LFOOT ELSE PFOOT ;
04100 FOR L ← L1 THRU L2 DO IF (X ← AA[C,L]) ≥ GRPOLX THEN
04200 BEGIN
04300 AA[TC, TL ← TL + 1] ← X ; AA[C, L] ← 0 ;
04400 IF LDB(FOOTM(X)) THEN DPB(F←IF F=31 THEN 1 ELSE F+1, FOOTM(X)) ;
04500 END ;
04600 IF C= COL THEN BEGIN LINE ← TL ; COL ← TC END ELSE BEGIN PINE ← TL ; PAL ← TC END ;
04700 END ;
04800 GRPOLX ← 0 ;
04900 END "SAME PAGE" ;
05000 DAPART ; RETURN(TRUE) ;
05100 END "MOVEGROUP" ;
00100 INTERNAL RECURSIVE INTEGER PROCEDURE FIND_ROOM(INTEGER SOURCE,
00200 EXTRA, FROMCOL, FROMLINE, MORECOMING) ;
00300 BEGIN "FIND_ROOM"
00400 INTEGER WANT, LEAD, I, C, L, SAVEAREA, KOLS ; LABEL FOUND, TRYHERE ;
00500 ASSUREAREA ;
00600 IF SOURCE≤0 THEN BEGIN WANT←EXTRA ; LEAD←-SOURCE END ELSE BEGIN WANT←1; LEAD←0 END;
00700 IF WANT > LINES THEN TES 12/6/73 LENGTHENED MESSAGE ;
00725 BEGIN WARN("CAN'T FIT HERE",
00750 "THIS LINE (WITH ITS PREFACE,SPREAD,SOMESCRIPTS) NEEDS " &
00775 CVS(WANT) & " LINES OF PAPER,
00787 BUT AREA " & SYM[LDB(BIXNUM(AREAIXM))] &
00793 " IS DECLARED ONLY " & CVS(LINES) & " LINES HIGH");
00796 RETURN(FALSE) ;
00798 END;
00800 KOLS ← IF FROMCOL > COLS THEN 2*COLS ELSE COLS ;
00900 TRYHERE:
01000 FOR C ← FROMCOL THRU KOLS DO
01100 IF (LINES-MORECOMING) - (L← IF C=FROMCOL THEN FROMLINE ELSE 0) + XGENLINES - PINE ≥
01200 (IF L THEN WANT+LEAD ELSE WANT) THEN GO TO FOUND ;
01300 IF GLINEM ∧ C≠FROMCOL ∧ MOVEGROUP(TRUE, KOLS+1-COLS,0,EXTRA) THEN
01350 BEGIN C←COL; L←LINE; GO FOUND END ;
01400 IF TEXTAR(AREAIXM) THEN
01450 BEGIN
01500 NEXTPAGE ; OPENAREA(AREAIXM) ;
01600 IF FROMCOL>COLS ∧ COL≤COLS ∨ FROMCOL≤COLS ∧ COL>COLS THEN
01700 BEGIN
01800 TES 12/6/73 DELETED: IF FROMCOL>COLS THEN FOOTTOP ← 1 ; COMMENT ADDED BY RKJ ;
01900 PAL ↔ COL ; LINE ↔ PINE ;
02000 END ;
02100 FROMCOL ← COL ; FROMLINE ← LINE; GO TO TRYHERE ;
02150 END
02200 ELSE BEGIN TES 12/6/73 LENGTHENED MESSAGE ;
02250 WARN("TITLE AREA OVERFLOW","Overflowed title area " & SYM[LDB(BIXNUM(AREAIXM))]) ;
02300 FOR C ← 1 THRU COLS DO AA[C, 0] ← AA[COLS+C,0] ← 0 ;
02400 PAL ← (C ← COL ← 1) + COLS ; L ← 0 ;
02500 END ;
02600 FOUND:
02700 IF C=COL THEN LINE←L
02800 ELSE IF GLINEM ∧ MOVEGROUP(FALSE, C, L, EXTRA) THEN BEGIN L ← LINE ; C ← COL END
02900 ELSE BEGIN
03000 COL ← C ; PAL ← (COL+COLS-1) MOD (2*COLS) + 1 ;
03100 LINE ← L ; PINE ← RH("AA[PAL,0]") ;
03200 END ;
03300 IF OLX+WANT+LEAD > OLXX THEN GROWOWLS(WANT+LEAD+25) ;
03400 IF LINE AND LEAD THEN
03500 BEGIN
03600 FOR I ← 1 THRU LEAD DO AA[COL, LINE+I] ← NEWBLANK(IF GROUPM ∨ I>1 THEN ABV_BLW ELSE BLW) ;
03700 LINE ← LINE + LEAD ;
03800 END ;
03900 RETURN(L+1) ;
04000 END "FIND_ROOM" ;
04100
04200 INTERNAL RECURSIVE PROCEDURE TOCOLUMN(INTEGER COLNO) ; IF ON THEN
04300 BEGIN "TOCOLUMN"
04400 ASSUREAREA ;
04500 IF COLNO < COL ∨ (COLNO=COL ∧ LINE) OR TES 10/25/73; COLNO>COLS THEN NEXTPAGE ;
04600 IF 1≤COLNO≤COLS THEN COL←COLNO ELSE
04700 BEGIN TES 10/25/73;
04800 WARN(NULL, "SKIP TO NONEXISTENT COLUMN "&CVS(COLNO));
04900 COLNO ← 1 ;
05000 END ;
05100 LINE ← 0 ; IF COL>1 THEN OPENAREA(AREAIXM) ;
05200 END "TOCOLUMN" ;
05300
05400 INTERNAL RECURSIVE PROCEDURE TOLINE(INTEGER LINENO) ; IF ON THEN
05500 BEGIN "TOLINE"
05600 ASSUREAREA ;
05700 IF LINENO < LINE THEN
05800 IF COL = COLS THEN
05900 BEGIN NEXTPAGE ; IF LINENO>1 THEN OPENAREA(AREAIXM) END
06000 ELSE BEGIN COL ← COL+1 ; LINE ← 0 ; END ;
06100 IF LINENO=1 THEN LINE←1 ELSE FIND_ROOM(0, 0, COL, LINENO-1, 0) ;
06200 END "TOLINE" ;
06300
06400 INTERNAL RECURSIVE PROCEDURE SKIPLINES(INTEGER HMLINES) ; IF ON THEN
06500 BEGIN "SKIPLINES"
06600 ASSUREAREA ;
06700 IF HMLINES > 0 THEN
06800 IF GROUPM=0 THEN FIND_ROOM(-HMLINES, 0, COL, LINE, 0)
06900 ELSE BEGIN "GROUP SKIP"
07000 INTEGER I ;
07100 FIND_ROOM(0, HMLINES, COL, LINE, 0) ;
07200 IF ¬GLINEM THEN GLINEM ← OLX + 1 ;
07300 FOR I ← 1 THRU HMLINES DO AA[COL, LINE+I] ←
07400 NEWBLANK(IF GLINEM=0 ∧ I=1 THEN ABV ELSE ABV_BLW) ;
07500 LINE ← LINE + HMLINES ;
07600 END "GROUP SKIP" ;
07700 END "SKIPLINES" ;
07800
00100 INTERNAL RECURSIVE PROCEDURE PLACELINE(INTEGER CHARS,POSN,XPOSN,FAKE,
00200 ABOVE,BELOW,LEADB,FIRSTLBL,JUSTIFY,MORECOMING) ;
00300 BEGIN "PLACELINE"
00400 INTEGER FOOTFLAG, NEEDS, TOPLINE, GR, ATOP, I, TOLBL, LBL, FOOTNUM, WASFRAME, WASCOL, WASOLX ;
00500 COMMENT FOOTFLAG CHANGES RKJ 10-10-73;
00600 STRING COWL, XREF, SOWL ;
00700 IF ¬DEBUG THEN XREF ← ALTMODE
00800 ELSE BEGIN
00900 XREF ← ERRLINE&"/"&SRCPAGE&"["&MACLINE&"]" ;
01000 FOR I ← 1 THRU MESGS DO XREF ← XREF & RUBOUT & MESSAGE[I] ;
01100 MESGS←0 ; XREF ← XREF & ALTMODE ;
01200 END ;
01300 IFC VERSION=SAILVER OR VERSION=PARCVER
01400 THENC IF XCRIBL THEN ABOVE←BELOW←0; comment scripts; ENDC
01500 COWL ← XREF & (SOWL←OWL[1 TO CHARS] & CRLF) ;
01600 ASSUREAREA ;
01650 IF COL > COLS THEN
01675 BEGIN "INFOOT" TES 12/6/73 SEPARATED CASES ;
01700 IF FOOTNUM ← FOOTTOP THEN
01800 BEGIN comment First Footnote belonging to a line ;
01900 GR ← GROUPM ; IF GROUPM=0 THEN GLINEM ← AA[COL,PINE] ; GROUPM ← 1 ; FOOTTOP ← 0 ;
01950 END ;
02000 IF ATOP ← LINE=0 THEN ABOVE ← ABOVE + 1 + FOOTGAP ; comment assure room for FOOTSEP ;
02100 END "INFOOT" ;
02200 FOOTFLAG ← COL ≤ COLS AND FULSTR("SSTK[FOOTSTR(AREAIXM)]");
02300 IF FOOTFLAG THEN
02400 MORECOMING←MORECOMING+2; RKJ 11/20/73 ;
02500 WHILE ¬(TOPLINE ← FIND_ROOM(-LEADB,NEEDS←ABOVE+BELOW+1,COL,LINE,MORECOMING)) DO
02600 BEGIN ABOVE←(ABOVE-1)MAX 0; BELOW←(BELOW-1)MAX 0 END;
02700 IF XCRIBL AND (COL = 1 OR COL = COLS+1) THEN TES 11/19/73 COL 1 ONLY! ;
02800 BEGIN "KLUDGE"
02900 OVEREST←OVEREST+NEEDS*(STDCHARH-CHARH);
03000 IF ABS(OVEREST)>STDCHARH THEN
03100 BEGIN
03200 XGENLINES←XGENLINES+OVEREST DIV STDCHARH;
03300 OVEREST←OVEREST MOD STDCHARH;
03400 END;
03500 END "KLUDGE";
03600 WASOLX ← OLX - (LINE + 1 - TOPLINE) ;
03640 IF COL > COLS THEN
03680 BEGIN "BEGFOOT" TES 12/6/73 SEPARATED CASES ;
03700 IF FOOTNUM THEN COMMENT FIRST FOOTNOTE BELONGING TO A LINE ;
03800 BEGIN "FOOT1"
03900 GROUPM ← GR ; IF GROUPM=0 THEN GLINEM ← 0 ;
03940 END "FOOT1" ;
04000 IF ATOP THEN BEGIN ABOVE ← ABOVE - 1 - FOOTGAP ; TES 11/29/73 ;
04050 NEEDS ← NEEDS - 1 - FOOTGAP END ;
04100 IF LINE = 0 THEN
04150 BEGIN "SEP" TES 11/29/73 ADDED FOOTGAP AND ENOUGH ;
04162 FOR I ← 1 THRU FOOTGAP DO AA[COL,I] ←
04168 NEWBLANK(IF I=1 THEN ABV ELSE ABV_BLW) ;
04175 AA[COL, LINE←TOPLINE←1+FOOTGAP] ← OLX ← OLX + 1 ;
04192 IF XCRIBL THEN
04194 OWT(XREF&PICKFONT(FSFONT)&ENOUGH(FOOTSEP,COLWID(AREAIXM),FSFONT)&CRLF)
04197 ELSE
04200 OWT(XREF&FOOTSEP[1 TO COLWID(AREAIXM)]&CRLF) ;
04205 MOLES[OLX] ← IF FOOTGAP=0 THEN BLW ELSE ABV_BLW ;
04210 END "SEP" ;
04300 END "BEGFOOT" ;
04400 FOR I ← 1 THRU ABOVE DO AA[COL,LINE+I] ←
04500 NEWBLANK(IF GROUPM ∨ TOPLINE<LINE+I THEN ABV_BLW ELSE BLW) ;
04600 AA[COL, LINE+ABOVE+1] ← OLX ← OLX + 1 ;
04700 OWT(COWL) ;
04800 MOLES[OLX] ← (IF GROUPM ∨ TOPLINE<LINE+ABOVE+1 THEN ABV ELSE 0) LOR (IF GROUPM OR BELOW THEN BLW ELSE 0);
04900 IF XCRIBL THEN I←MAXIM*CHARW + FAKE - XPOSN ELSE I←MAXIM - (POSN-FAKE);
05000 IF JUSTIFY AND I > 0 THEN SHORT[OLX]←I ;
05100 IF FIRSTLBL≠-TWO(13) THEN
05200 BEGIN "PAGE LABELS"
05300 LBL ← PLBL ; TOLBL ← 0 ;
05400 WHILE LBL≠FIRSTLBL ∧ LBL≠-TWO(13) DO
05500 LBL ← IF (TOLBL←LBL)>0 THEN ITBL[TOLBL] ELSE NUMBER[-TOLBL] ;
05600 IF LBL=-TWO(13) THEN WARN("=","Page label not in Page Label L.L.!!!")
05700 ELSE IF TOLBL=0 THEN PLBL ← -TWO(13)
05800 ELSE IF TOLBL > 0 THEN ITBL[TOLBL] ← -TWO(13)
05900 ELSE NUMBER[-TOLBL] ← -TWO(13) ;
06000 BRKPLBL ← PLBL ;
06100 DPB(IF FIRSTLBL<0 THEN PUTI(1,FIRSTLBL) ELSE FIRSTLBL, LABELM(OLX)) ;
06200 END "PAGE LABELS" ;
06300 FOR I ← ABOVE+2 THRU NEEDS DO AA[COL,LINE+I] ← NEWBLANK(IF GROUPM ∨ I<NEEDS THEN ABV_BLW ELSE BLW) ;
06400 IF GROUPM∧¬GLINEM THEN
06475 DPB(0,ABOVEM("GLINEM←IF COL>COLS THEN TOPMOST(PAL,PINE) ELSE AA[COL,TOPLINE]")) ;
06487 TES 12/6/73 ADDED TOPMOST(PAL,PINE) ;
06500 LINE ← LINE + NEEDS ;
06600 IF FOOTFLAG THEN comment, Footnotes ;
06700 BEGIN "FOOTNOTES"
06800 WHILE (FOOTNUM←IF PINE=0 THEN 1 ELSE LDB(FOOTM("AA[PAL,PINE]")) + 1) = 31 DO
06900 BEGIN
07000 WARN("=",">30 lines in col. "&COL&" want footnotes.") ;
07100 FIND_ROOM(LINE, 1, COL+1, 0, 0) ;
07200 END ;
07300 IF FOOTNUM=32 THEN FOOTNUM ← 1 ; DPB(FOOTNUM, FOOTM(OLX)) ;
07400 SEND(IXFOOT, CRLF&TB&TB& "END ""!FOOTNOTES"";;") ;
07500 AA[COL,0] ← LHRH(COVERED, LINE) ; PINE ↔ LINE ; PAL ↔ COL ;
07600 WASCOL ← COL ; WASFRAME ← FRAMEIDA ; BEGINBLOCK(TRUE, 3, "!FOOTNOTES") ; BREAKM ← 0 ;
07700 FOOTTOP ← -1 ; WASOLX ← OLX ; RECEIVE(IXFOOT, NULL) ; PASS ; TOEND ; FOOTTOP ← 0 ;
07800 AA[COL,0] ← LHRH(COVERED, LINE) ;
07900 IF WASCOL ≠ COL ∨ WASFRAME ≠ FRAMEIDA THEN
08000 BEGIN FOOTNUM ← 31 ; IF WASFRAME=FRAMEIDA THEN DPB(31, FOOTM(WASOLX)) END ;
08100 DPB(FOOTNUM, FOOTM("AA[COL,LINE]")) ; PAL ↔ COL ; PINE ↔ LINE ;
08200 END "FOOTNOTES" ;
08300 END "PLACELINE" ;
00100 COMMENT I N I T I A L I Z A T I O N P R O C E D U R E S - - - - - - - - - - ;
00200
00300 INTERNAL SIMPLE PROCEDURE FAMILYHAS(INTEGER FAMNUM; STRING MEMBERS) ;
00400 BEGIN "FAMILYHAS"
00500 INTEGER SPECIE, CHAR ;
00600 SPECIE ← -1 ;
00700 WHILE FULSTR(MEMBERS) DO
00800 BEGIN
00900 DPB(FAMNUM, FAMILY("CHAR ← LOP(MEMBERS)")) ;
01000 DPB(SPECIE ← SPECIE+1, SPECIES(CHAR)) ;
01100 END ;
01200 END "FAMILYHAS" ;
01300
01400 EXTERNAL SIMPLE PROCEDURE MANUSCRIPT ;
00100 COMMENT I N I T I A L I Z E A N D G O ! ! ! ! ! ;
00200
00300 COMMENT Set up the XGP stuff ;
00400 CHARW ← 16 ; COMMENT fix later ;
00500 WCW ← WHATIS(CW) ; COMMENT original font ;
00600 THISFONT ← OLDFONT ← DEFAULTFONT ;
00620
00640 FSFONT ← DEFAULTFONT ; FOOTGAP ← 0 ; TES 11/29/73 ;
00700
00800 IFC TENEX THENC
00900 JOBNO ← CVS(GJINF(J, I, J)) ;
01000 CONDIR ← DIRST(I) ;
01100 ENDC TES 10/25/73 ;
01200
01300 ON ← TRUE ; comment only false if code is to be parsed but not executed ;
01400 WISTK←WHATIS(ISTK) ; WITBL←WHATIS(ITBL) ; WINEST←WHATIS(INEST) ;
01500 WSSTK←SWHATIS(SSTK) ; WSTBL←SWHATIS(STBL) ; WSNEST←SWHATIS(SNEST) ;
01600 WSYM←SWHATIS(SYM) ; WNUMBER←WHATIS(NUMBER) ; WOLDPAGE←WHATIS(OLDPAGE) ;
01700 WNEWPAGE←WHATIS(NEWPAGE) ; WTHISFRAME←WHATIS(THISFRAME);
01800 WMOLES←WHATIS(MOLES) ; WOWLS←WHATIS(OWLS) ; WNMOLES←WHATIS(NMOLES) ;
01900 WNOWLS←WHATIS(NOWLS) ; WTHISAREA←WHATIS(THISAREA) ; WWAITBOX←WHATIS(WAITBOX) ;
02000 WAVAILREC←WHATIS(AVAILREC) ; WAA←WHATIS(AA) ; WNAA←WHATIS(NAA) ;
02100 WSHORT←WHATIS(SHORT) ; WNSHORT←WHATIS(NSHORT) ;
02200 ITBLIDA ← RH("CREATE(0, ITSIZE)") ; ISTKIDA ← RH("CREATE(0, ISIZE)") ; INESTIDA ← RH("CREATE(0, SIZE)") ;
02300 STBLIDA ← RH("SCREATE(0, STSIZE)") ; SSTKIDA ← RH("SCREATE(0, SSIZE)") ; SNESTIDA ← RH("SCREATE(0, SIZE)") ;
02400 SYMIDA ← RH("SCREATE(-1, SYMNO)") ; NUMBIDA ← RH("CREATE(-1, SYMNO)") ;
02500 MAKEBE(ITBLIDA, ITBL) ; MAKEBE(ISTKIDA, ISTK) ; MAKEBE(INESTIDA, INEST) ;
02600 SMAKEBE(STBLIDA, STBL) ; SMAKEBE(SSTKIDA, SSTK) ; SMAKEBE(SNESTIDA, SNEST) ;
02700 SMAKEBE(SYMIDA, SYM) ; MAKEBE(NUMBIDA, NUMBER) ;
02800 SETSYM ; XSYMNO ← SYMNO ; comment Initialize the symbol table;
02900 LAST ← IHED ← SHED ← IHIGH ← SHIGH ← 0 ; comment Tops of Stacks;
03000 OLDPGIDA←NEWPGIDA←FRAMEIDA←MOLESIDA←SHORTIDA←OWLSIDA←AREAIDA←WBOXIDA←STATUS←AREAIXM←0 ;
03100 DEPTH ← GENSYM ← 0 ; OLX ← -1 ; OLMAX ← 5 ; LEADRESPS ← WAITRESP ← 0 ;
03200 FOR I ← 0 STEP 1 WHILE FULSTR(MANWD[I]) DO
03300 BIND(DECLARE(SYMNUM(MANWD[I]), MANTYPE), I) ; comment reserved words ;
03400 DEPTH ← 2 ; IXCOMMENT ← LDB(IXN("SYMNUM(""""COMMENT"""")")) ;
03500 SYMTEXT ← SYMNUM("TEXT") ; IXEND←LDB(IXN("SYMNUM(""""END"""")"));
03600 J ← 0 ;
03700 FOR S ← CR, ALTMODE&"{", RUBOUT, "α", "β", "#", "\", "∂", "←", "→", "∞",
03800 "↑", "↓", "]", "-", ".!?", SP, "_", "π", "∪", "∩", VT, "$", "%",
03900 "⊗", "[", "&" DO
04000 COMMENT 2D CHARS OF DIPHTHONGS COME NOT BEFORE [ IN LIST ↑ ;
04100 BEGIN J←J+1; WHILE FULSTR(S) DO DPB(J, SPCHAR("LOP(S)")) ; END ;
04200 AMSAND ← J ; LBRACK ← J-1 ; UNDERBAR ← 18 ; UARROW ← 12 ; DARROW ← 13 ;
04300 LCURLY ← 2 ; DOLLAR ← 23 ; XCMDCHR ← 25 ;
04400 FOR S ← SP, TB, FF, VT, CR, LF, 0 DO CHARTBL[S] ← CHARTBL[S] LOR TWO(6) ;
04500 CHARSP ← CR & ALTMODE & RUBOUT & "αβ#\∂←→∞↑↓]-? _π∪∩" & VT & "$%⊗[&" ;
04600 FOR J ← 0 THRU 127 DO BEGIN DPB(MISCQ, FAMILY(J)) ; DPB(0, SPECIES(J)) END ;
04700 FAMILYHAS(LETTQ, "ABCDEFGHIJKLMNOPQRSTUVWXYZ!") ;
04800 FAMILYHAS(LETTQ, "abcdefghijklmnopqrstuvwxyz_") ;
04900 FAMILYHAS(DIGQ, "0123456789" ) ;
05000 FAMILYHAS(EMPTYQ, '0 & ALTMODE & RUBOUT) ;
05100 FAMILYHAS(TERQ, RCBRAK&";),]⊂" ) ;
05200 FAMILYHAS(QUOTEQ, """'" ) ;
05300 FAMILYHAS(DOLLARQ, "$" ) ;
05400 FAMILYHAS(BROKQ, "[" ) ;
05500 FAMILYHAS(MULQ, "*/%&" ) ;
05700 FAMILYHAS(ADDQ, "+-≡↑⊗" ) ;
05800 FAMILYHAS(RELQ, "<>=≤≥≠" ) ;
05900 FAMILYHAS(NOTQ, "¬" ) ;
06000 FAMILYHAS(ANDQ, "∧" ) ;
06100 FAMILYHAS(ORQ, "∨" ) ;
06200 FAMILYHAS(MISCQ, " :←(∞@|ε" ) ;
06300 FOR S ← "∧AND", "∨OR", "¬NOT", "/DIV", "≡EQV", "⊗XOR", "≡ABS", "⊗LENGTH", "≤LEQ", "≥GEQ", "≠NEQ" DO
06400 BIND(DECLARE(SYMNUM(S[2 TO ∞]), INTERNTYPE), S+200) ; ie, equate with special character ;
06500 J ← RUBOUT ;
06600 FOR S ← ODDQ&0&"EVEN", ODDQ&1&"ODD",
06700 BOUNDQ&0&"MAX", BOUNDQ&1&"MIN", MULQ&2&"MOD" DO
06800 BEGIN
06900 INTEGER TEMP ; COMMENT SAIL BUG -- THANKS RKJ ;
07000 BIND(DECLARE(SYMNUM(S[3 TO ∞]), INTERNTYPE), (J←J+1)+200) ;
07100 DPB(TEMP←S[1 FOR 1], FAMILY(J)) ;
07200 DPB(TEMP←S[2 FOR 1], SPECIES(J)) ;
07300 END ;
00100 UPCAS3←(UPCASE(0)) LOR '3000000 ; COMMENT POINT 7, CHARTBL(3), 6 ;
00200 UPCAS5←(UPCASE(0)) LOR '5000000 ; UPCAS6←(UPCASE(0)) LOR '6000000 ;
00300 FOR J ← 0 THRU 127 DO DPB(J, UPCASE(J)) ;
00400 FOR J ← "a" THRU "z" DO DPB(J-("a"-"A"), UPCASE(J)) ; DPB(J←"!", UPCASE("_")) ;
00500 J ← -1 ;
00600 FOR S ← "LINES", "COLUMNS", "!", "SPREAD", "FILLING", "!SKIP!", "!SKIPL!", "!SKIPR!",
00700 "NULL", "!INF", "FOOTSEP", "TRUE", "FALSE",
00800 "INDENT1", "INDENT2", "INDENT3", "LMARG", "RMARG",
00900 "CHAR", "CHARS", "LINE", "COLUMN", "TOPLINE", "XCRIBL", "CHARW",
01000 "XGENLINES", "UNDERLINE", "THISDEVICE", "THISFONT",
01020 "FOOTGAP", "FOOTSEPFONT", "TTY" DO
01100 BIND(DECLARE(SYMNUM(S), INTERNTYPE), J←J+1) ; comment Internal Variables;
01200 PLBL←BRKPLBL←-TWO(13); NOPGPH ← TRUE ;
01300 BIND(DECLARE(SYMNUM("FOOT"), PORTYPE), IXFOOT ← PUTI(4, -1)) ;
01400 VUNDERLINE ← BAR ; TES 10/22/73 ;
01500 ASSIGN("!CONTENTSW", CONTENTS) ; comment make RPG-switch available to macros;
01600 ASSIGN("FILE", IFC TENEX THENC CVFIL(INFILE,S,S) TES 10/30/73;
01700 ELSEC CVXSTR(CVFIL(INFILE,L,M)) ENDC) ;
01800 ! ← NULL ; K ← CALL(0, "DATE") ;
01900 ASSIGN("MONTH", (STR1 ← MONTH[K DIV 31 MOD 12 + 1])[1 TO ∞-1]) ;
02000 ASSIGN("DAY", STR2 ← CVS(K MOD 31 + 1)) ;
02100 ASSIGN("YEAR", STR3 ← CVS(K DIV 31 DIV 12 + 1964)) ;
02200 ASSIGN("DATE", STR1 & STR2 & ", " & STR3 );
02300 K ← CALL(0,"TIMER")/3600 ; S ← CVS(K MOD 60) ; IF LENGTH(S)=1 THEN S ← "0"&S ;
02400 ASSIGN("TIME", CVS(K DIV 60) & ":" & S) ;
02500 SYMPAGE←SYMNUM("PAGE"); CREUNIT(0,1,18,1,0,"1",SYMPAGE); IXPAGE←LDB(IXN(SYMPAGE));
02600 PATPAGE←PATT_STRS(IXPAGE); PAGEVAL ← NULL ;
02700 INTERS ← PORTS ← THISPORT ← 0 ; PORTLL ← SEQPORT ← PUTI(4, -5) ; PORSEQ(SEQPORT) ← INTER ← -1 ;
02800 INPUTCHAN ← -1 ; LIT_ENTITY ← LIT_TRAIL ← NULL ;
02900 INPUTSTR ← CRLF & "99999/99" & TB & TB & "<<)]"&RCBRAK&"⊃>>;END""PAST EOF"";END""PASSED EOF"";" ;
03000 TABSORT[1]←TWO(33); EXNEXTPAGE ← FALSE ; ENDCASE←STARTS←0 ; BLNMS←-1 ; AVAILREC[0] ← NULLAREAS ← 0 ;
03100 EMPTYTHIS ; EMPTYTHAT ;
03200 RESP_BODY ← DCLR_ID ← DCLR_LET ← FALSE ; OWLSEQ ← MESGS ← 0 ;
03300 THISFILE ← "(NO FILE)" ; MAINFILE ← INFILE ; COMMENT RESET IN SWICHF ;
03400 COMMAND_CHARACTER ← "." ;
03500 S ← TEXT_BRC ← CRLF & ALTMODE & RUBOUT & VT & " -.!?" ;
03600 WHILE FULSTR(S) DO DPB(LDB(SPCHAR("J ← LOP(S)")), SPCODE(J)) ;
03700 DEFN_BRC ← RCBRAK&"$)⊂⊃∃" & LF & LETTS ; LDEFN_BRC ← LENGTH(DEFN_BRC) ;
03800 SETBREAK(TO_VT_SKIP, VT, NULL, "IS") ;
03900 SETBREAK(TO_COMMA_RPAR, ",)" & LF, CR, "IR") ;
04000 COMMENT "|" IGNORED UNTIL 6 FEB 73;
04100 SETBREAK(TO_TERQ_CR, RCBRAK&";),]⊂"&CRLF, NULL, "IR") ;
04200 SETBREAK(TO_SEMI_SKIP, ";"&RCBRAK&""&LF, NULL, "IS") ;
04300 SETBREAK(NO_CHARS, NULL, NULL, "XRL") ;
04400 SETBREAK(ONE_CHAR, NULL, NULL, "XA") ;
04500 SETBREAK(TO_TB_FF_SKIP, TB&FF, LF, "IS") ;
04600 SETBREAK(TO_LF_TB_VT_SKIP, LF&TB&VT, FF, "ISL") ;
04700 SETBREAK(TO_VISIBLE, SP&CR, NULL, "XR") ;
04800 SETBREAK(ALPHA, LETTS&DIGS, NULL, "XR") ;
04900 SETBREAK(DIGITA, DIGS, NULL, "XR") ;
05000 SETBREAK(TO_QUOTE_APPD, """"&LF, NULL, "IA") ;
05100 SETBREAK(TO_NON_SP, SP, NULL, "XR") ;
05200 SETBREAK(TEXT_TBL, TEXT_BRC&SIG_BRC,NULL, "IS") ;
05300 SETBREAK(TO_VBAR_SKIP, "|"&LF, CR, "IS") ;
05400 SETBREAK(DEFN_TABLE, DEFN_BRC, NULL, "IS") ;
05500 SETBREAK(TO_CR_SKIP, CRLF, NULL, "IS") ;
05600 SWICH(CRLF & "9999/98" & TB & TB & "NEXT PAGE ; END ""!MANUSCRIPT"" ", -1, 0) ;
05700 SWICHF(INFILE) ; comment main input file ;
05800 SWICH("BEGIN ""!MANUSCRIPT"" ", -1, 0) ;
05900 IFC VERSION=CMUVER THENC
06000 LIBPPN ← "[A700PU00]";
06100 SIMLOOK("!DEFONTA");
06200 READFONT(DEFAULTFONT,"NGR25.KST[A730KS00]");
06300 ENDC COMMENT RKJ 10-10-73;
06400 IFC VERSION=SAILVER THENC
06500 LIBPPN ← IF EQU(CVXSTR(CALL(0,"DSKPPN"))[3 TO 6], "2TES") THEN NULL ELSE "[1,3]" ;
06600 ENDC;
06700 PUBSTD ← TRUE ; COMMENT SUPPRESS PAGE NUMBER MONITORING ;
06800 SWICHF("PUBSTD.DFS"&LIBPPN) ; comment standard modes and macros ;
06900 SPREADM ← PREFMODE ;
07000 PASS ; comment get scanner going ;
00100 MANUSCRIPT ; NB NB NB NB T H I S D O E S P A S S O N E ;
00200
00300 COMMENT Write out Labels for Pass Two ;
00400 L ← WRITEON(FALSE, "PULABL.PUI") ;
00500 OUT(L, CVSR(XSYMNO MAX IHIGH) ) ;
00600 FOR J ← 1 THRU XSYMNO DO
00700 IF (BYTEWD ← NUMBER[J]) ≠ 0 ∧ (K← LDB(SYMBOLWD(BYTEWD))) = 0 ∨ K='17777 THEN
00800 IF LDB(PLIGHTWD(BYTEWD)) = 2 THEN OUT(L, CVSR(0) & CVSR(J) & STBL[LDB(IXWD(BYTEWD))]&ALTMODE )
00900 ELSE WARN("=","Undefined Label "&SYM[J]) ;
01000 FOR J ← 1 THRU IHIGH DO IF LH(BYTEWD ← ITBL[J]) = '400000 THEN
01100 OUT(L, CVSR(1) & CVSR(J) & STBL[LDB(IXWD(BYTEWD))] & ALTMODE) ;
01200 RELEASE(L) ;
01300
01400 COMMENT Finish Last Page File and write out OUTFILE and Intermediate Sequence File ;
01500 IF INTER ≥ 0 THEN BEGIN FOR DUMMY←1 THRU 5 DO WORDOUT(INTER,-20) ; RELEASE(INTER) ; RELEASE(SINTER) END ;
01600 IF GENEXT THEN OUTFILE ← OUTFILE &
01700 IFC VERSION=CMUVER THENC (IF XCRIBL THEN ".XGO" ELSE ".DOC") ENDC
01800 IFC VERSION=SAILVER THENC ".DOC" ENDC
01900 IFC VERSION=PARCVER THENC ".DOC" ENDC;
02000 L ← WRITEON(FALSE,"PUPSEQ.PUI") ;
02100 OUT(L, TMPFILE&ALTMODE&OUTFILE&ALTMODE&CVSR(DEBUG)&CVSR("ABS(DEVICE)")&DELINT&ALTMODE) ;
02200 OUT(L, VUNDERLINE & ALTMODE) ; TES 10/22/73 ;
02300 OUT(L,CVSR(CHARW));
02400 SIMLOOK("!XGPLFTMAR"); OUT(L,EVALV("!XGPLFTMAR",SYMIX,SYMTYPE)&ALTMODE);
02500 OUT(L,CVSR(BASELINE));
02600 OUT(L,LF);
02700 J ← PORSEQ(PORTLL) ;
02800 OPEN(K ← GETCHAN, "DSK", 0,1,0,20, BRC, EOF) ;
02900 WHILE J > 0 DO
03000 BEGIN
03100 IF PORINT(J) THEN OUT(L, CVSTR(PORINT(J)) & ALTMODE) ;
03200 IF PORCH(J) = -5 ∨ PORSEQ(J) < 0 THEN WARN("=","INSERT Portion not found") ;
03300 IF PORFIL(J) THEN FOR S ← ".PUG", ".PUZ" DO IF EQU(S,".PUG") ∨ PORCH(J)=-6 THEN
03400 BEGIN COMMENT DELETE GENERATED FILES ;
03500 LOOKUP(K, CVSTR(PORFIL(J)) & S & JOBNO, DUMMY) ;
03600 IF DUMMY=0 THEN RENAME(K, NULL, 0, DUMMY) ;
03700 END ;
03800 J ← PORSEQ(J) ;
03900 END ;
04000 RELEASE(L) ; RELEASE(K) ;
04100
04200 IFC VERSION=SAILVER THENC
04300 IF FULSTR(CMDFILE) AND XCRIBL THEN
04400 BEGIN "WRITECMD"
04500 L←WRITEON(FALSE,"QQXGP.RPG");
04600 OUT(L,OUTFILE&"/NOHEADING/LMAR=");
04700 SIMLOOK("!XGPLFTMAR"); OUT(L,EVALV("!XGPLFTMAR",SYMIX,SYMTYPE));
04800 SIMLOOK("!XGPCOMMANDS"); OUT(L,EVALV("!XGPCOMMANDS",SYMIX,SYMTYPE));
04900 OUT(L,CMDFILE&CRLF);
05000 RELEASE(L)
05100 END "WRITECMD"
05200 ENDC;
05300 OUTSTR(CRLF) ;
05400
05500 FOR J ← ITBLIDA, ISTKIDA, INESTIDA, NUMBIDA DO GOAWAY(J) ;
05600 FOR J ← STBLIDA, SSTKIDA, SNESTIDA, SYMIDA DO GOAWAY(-1 LSH 18 + J) ;
05700 FOR J ← 1 THRU 35 DO IF FONTFIL[J] ≠ 0 THEN GOAWAY(FONTFIL[J]) ;
05800
05900 MAKEBE(WCW,CW);
06000 MAKEBE(WISTK, ISTK) ; MAKEBE(WITBL, ITBL) ; MAKEBE(WINEST, INEST) ;
06100 SMAKEBE(WSSTK, SSTK) ; SMAKEBE(WSTBL, STBL) ; SMAKEBE(WSNEST, SNEST) ;
06200 SMAKEBE(WSYM, SYM) ; MAKEBE(WNUMBER, NUMBER) ; MAKEBE(WOLDPAGE, OLDPAGE) ;
06300 MAKEBE(WNEWPAGE, NEWPAGE) ; MAKEBE(WTHISFRAME,THISFRAME);
06400 MAKEBE(WMOLES, MOLES) ; MAKEBE(WOWLS, OWLS) ; MAKEBE(WNMOLES, NMOLES) ;
06500 MAKEBE(WSHORT, SHORT) ; MAKEBE(WNSHORT, NSHORT) ;
06600 MAKEBE(WNOWLS, NOWLS) ; MAKEBE(WTHISAREA, THISAREA) ; MAKEBE(WWAITBOX, WAITBOX) ;
06700 MAKEBE(WAVAILREC, AVAILREC) ; MAKEBE(WAA, AA) ; MAKEBE(WNAA, NAA) ;
06800
06900 END "VARIABLE BOUND ARRAY BLOCK" ;
07000
07100 IFC TENEX THENC TES 10/25/73 ;
07200 BEGIN "PASS 2"
07300 RUNPRG(IF EQU(CONDIR,"<PUB>") THEN "<PUB>PUB2.SAV" ELSE "<SUBSYS>PUB2.SAV", 1,0) ;
07400 END "PASS 2"
07500 ELSEC
07600 IFC VERSION=CMUVER THENC
07700 BEGIN "PASS 2"
07800 INTEGER ARRAY PASSTWO[0:4];
07900 PASSTWO[0] ← CVSIX(LIBDEV);
08000 PASSTWO[1] ← CVFIL("PUB2"&LIBPPN,PASSTWO[2],PASSTWO[4]);
08100 PASSTWO[3] ← 0;
08200 START_CODE
08300 MOVE 1,PASSTWO;
08400 HRLI 1,1;
08500 CALLI 1,'35;
08600 JRST 4,0;
08700 END;
08800 END "PASS 2"
08900 ELSEC
09000 IFC VERSION=SAILVER THENC
09100 BEGIN "PASS 2"
09200 INTEGER SIMPLE PROCEDURE CORELOC(INTEGER ARRAY A) ; START_CODE MOVE 1,A ; END ;
09300
09400 INTEGER ARRAY PASSTWO[0:4] ;
09500 EXTERNAL SIMPLE PROCEDURE K_OUT ; K_OUT ; COMMENT * * * * * * * * * * * ;
09600 PASSTWO[0] ← CVSIX("DSK") ; PASSTWO[1] ← CVFIL("PUB2.DMP"&LIBPPN, PASSTWO[2], PASSTWO[4]) ;
09700 PASSTWO[3] ← 1 ; COMMENT Do an RPGSTART so DEVICE will be taken from PUI file ;
09800 CALL(CORELOC(PASSTWO), "SWAP") ;
09900 END "PASS 2"
10000 ELSEC
10100 IFC VERSION=PARCVER THENC
10200 BEGIN "PASS 2" RKJ NON-TENEX SAIL ;
10300 INTEGER FH;
10400 DEFINE JSYS="'104000000000",
10500 RESET="JSYS '147", GTJFN="JSYS '20",
10600 CFORK="JSYS '152", WFORK="JSYS '163",
10700 HALTF="JSYS '170", GET="JSYS '200",
10800 SFRKV="JSYS '201";
10900 S←"<SUBSYS>PUB2.SAV "; TES 10/25/73 ;
11000 START!CODE
11100 RESET;
11200 MOVSI 1,'200000;
11300 CFORK; HALTF;
11400 MOVEM 1,FH;
11500 MOVSI 1,'100001;
11600 MOVE 2,S;
11700 GTJFN; HALTF;
11800 HRL 1,FH;
11900 GET;
12000 MOVE 1,FH;
12100 MOVEI 2,2;
12200 SFRKV;
12300 MOVE 1,FH;
12400 WFORK;
12500 RESET;
12600 HALTF;
12700 END;
12800 END "PASS 2";
12900 ENDC ENDC ENDC ENDC
13000
13100 END "PUB"